Session Berlekamp_Zassenhaus

Theory Finite_Field

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹Finite Rings and Fields›

text ‹We start by establishing some preliminary results about finite rings and finite fields›

subsection ‹Finite Rings›

theory Finite_Field
imports 
  "HOL-Computational_Algebra.Primes"
  "HOL-Number_Theory.Residues"
  "HOL-Library.Cardinality"
  Subresultants.Binary_Exponentiation
  Polynomial_Interpolation.Ring_Hom_Poly
begin

typedef ('a::finite) mod_ring = "{0..<int CARD('a)}" by auto

setup_lifting type_definition_mod_ring

lemma CARD_mod_ring[simp]: "CARD('a mod_ring) = CARD('a::finite)" 
proof -
  have "card {y. x{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} = card {0..<int CARD('a)}"
  proof (rule bij_betw_same_card)
    have "inj_on Rep_mod_ring {y. x{0..<int CARD('a)}. y = Abs_mod_ring x}"
      by (meson Rep_mod_ring_inject inj_onI)      
    moreover have "Rep_mod_ring ` {y. x{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} = {0..<int CARD('a)}"
    proof (auto simp add: image_def Rep_mod_ring_inject)
      fix xb show "0  Rep_mod_ring (Abs_mod_ring xb)" 
        using Rep_mod_ring atLeastLessThan_iff by blast 
      assume xb1: "0  xb" and xb2: "xb < int CARD('a)"
      thus " Rep_mod_ring (Abs_mod_ring xb) < int CARD('a)"
        by (metis Abs_mod_ring_inverse Rep_mod_ring atLeastLessThan_iff le_less_trans linear)
      have xb: "xb  {0..<int CARD('a)}" using xb1 xb2 by simp
      show "xa::'a mod_ring. (x{0..<int CARD('a)}. xa = Abs_mod_ring x)  xb = Rep_mod_ring xa"
      by (rule exI[of _ "Abs_mod_ring xb"], auto simp add: xb1 xb2, rule Abs_mod_ring_inverse[OF xb, symmetric])
    qed    
    ultimately show "bij_betw Rep_mod_ring
      {y. x{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} 
      {0..<int CARD('a)}"
      by (simp add: bij_betw_def)
  qed
  thus ?thesis
    unfolding type_definition.univ[OF type_definition_mod_ring]
    unfolding image_def by auto
qed

instance mod_ring :: (finite) finite 
proof (intro_classes)
  show "finite (UNIV::'a mod_ring set)" 
    unfolding type_definition.univ[OF type_definition_mod_ring]
    using finite by simp
qed


instantiation mod_ring :: (finite) equal
begin
lift_definition equal_mod_ring :: "'a mod_ring  'a mod_ring  bool" is "(=)" .
instance by (intro_classes, transfer, auto)
end

instantiation mod_ring :: (finite) comm_ring
begin

lift_definition plus_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring" is
  "λ x y. (x + y) mod int (CARD('a))" by simp

lift_definition uminus_mod_ring :: "'a mod_ring  'a mod_ring" is
  "λ x. if x = 0 then 0 else int (CARD('a)) - x" by simp

lift_definition minus_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring" is
  "λ x y. (x - y) mod int (CARD('a))" by simp

lift_definition times_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring" is
  "λ x y. (x * y) mod int (CARD('a))" by simp

lift_definition zero_mod_ring :: "'a mod_ring" is 0 by simp

instance
  by standard
    (transfer; auto simp add: mod_simps algebra_simps intro: mod_diff_cong)+

end

lift_definition to_int_mod_ring :: "'a::finite mod_ring  int" is "λ x. x" .

lift_definition of_int_mod_ring :: "int  'a::finite mod_ring" is
  "λ x. x mod int (CARD('a))" by simp

interpretation to_int_mod_ring_hom: inj_zero_hom to_int_mod_ring
  by (unfold_locales; transfer, auto)

lemma int_nat_card[simp]: "int (nat CARD('a::finite)) = CARD('a)" by auto

interpretation of_int_mod_ring_hom: zero_hom of_int_mod_ring
  by (unfold_locales, transfer, auto)

lemma of_int_mod_ring_to_int_mod_ring[simp]:
  "of_int_mod_ring (to_int_mod_ring x) = x" by (transfer, auto)

lemma to_int_mod_ring_of_int_mod_ring[simp]: "0  x  x < int CARD('a :: finite) 
  to_int_mod_ring (of_int_mod_ring x :: 'a mod_ring) = x"
  by (transfer, auto)

lemma range_to_int_mod_ring:
  "range (to_int_mod_ring :: ('a :: finite mod_ring  int)) = {0 ..< CARD('a)}"
  apply (intro equalityI subsetI)
  apply (elim rangeE, transfer, force)
  by (auto intro!: range_eqI to_int_mod_ring_of_int_mod_ring[symmetric])

subsection ‹Nontrivial Finite Rings›

class nontriv = assumes nontriv: "CARD('a) > 1"

subclass(in nontriv) finite by(intro_classes,insert nontriv,auto intro:card_ge_0_finite)

instantiation mod_ring :: (nontriv) comm_ring_1
begin

lift_definition one_mod_ring :: "'a mod_ring" is 1 using nontriv[where ?'a='a] by auto

instance by (intro_classes; transfer, simp)

end

interpretation to_int_mod_ring_hom: inj_one_hom to_int_mod_ring
  by (unfold_locales, transfer, simp)

lemma of_nat_of_int_mod_ring [code_unfold]:
  "of_nat = of_int_mod_ring o int"
proof (rule ext, unfold o_def)
  show "of_nat n = of_int_mod_ring (int n)" for n
  proof (induct n)
    case (Suc n)
    show ?case
      by (simp only: of_nat_Suc Suc, transfer) (simp add: mod_simps)
  qed simp
qed

lemma of_nat_card_eq_0[simp]: "(of_nat (CARD('a::nontriv)) :: 'a mod_ring) = 0"
  by (unfold of_nat_of_int_mod_ring, transfer, auto)

lemma of_int_of_int_mod_ring[code_unfold]: "of_int = of_int_mod_ring"
proof (rule ext)
  fix x :: int
  obtain n1 n2 where x: "x = int n1 - int n2" by (rule int_diff_cases)
  show "of_int x = of_int_mod_ring x"
    unfolding x of_int_diff of_int_of_nat_eq of_nat_of_int_mod_ring o_def
    by (transfer, simp add: mod_diff_right_eq mod_diff_left_eq)
qed

unbundle lifting_syntax

lemma pcr_mod_ring_to_int_mod_ring: "pcr_mod_ring = (λx y. x = to_int_mod_ring y)"
 unfolding mod_ring.pcr_cr_eq unfolding cr_mod_ring_def to_int_mod_ring.rep_eq ..

lemma [transfer_rule]:
  "((=) ===> pcr_mod_ring) (λ x. int x mod int (CARD('a :: nontriv))) (of_nat :: nat  'a mod_ring)"
  by (intro rel_funI, unfold pcr_mod_ring_to_int_mod_ring of_nat_of_int_mod_ring, transfer, auto)

lemma [transfer_rule]:
  "((=) ===> pcr_mod_ring) (λ x. x mod int (CARD('a :: nontriv))) (of_int :: int  'a mod_ring)"
  by (intro rel_funI, unfold pcr_mod_ring_to_int_mod_ring of_int_of_int_mod_ring, transfer, auto)

lemma one_mod_card [simp]: "1 mod CARD('a::nontriv) = 1"
  using mod_less nontriv by blast 

lemma Suc_0_mod_card [simp]: "Suc 0 mod CARD('a::nontriv) = 1"
  using one_mod_card by simp

lemma one_mod_card_int [simp]: "1 mod int CARD('a::nontriv) = 1"
proof -
  from nontriv [where ?'a = 'a] have "int (1 mod CARD('a::nontriv)) = 1"
    by simp
  then show ?thesis
    using of_nat_mod [of 1 "CARD('a)", where ?'a = int] by simp
qed

lemma pow_mod_ring_transfer[transfer_rule]:
  "(pcr_mod_ring ===> (=) ===> pcr_mod_ring) 
   (λa::int. λn. a^n mod CARD('a::nontriv)) ((^)::'a mod_ring  nat  'a mod_ring)"
unfolding pcr_mod_ring_to_int_mod_ring
proof (intro rel_funI,simp)
  fix x::"'a mod_ring" and n
  show "to_int_mod_ring x ^ n mod int CARD('a) = to_int_mod_ring (x ^ n)"
  proof (induct n)
    case 0
    thus ?case by auto
  next
    case (Suc n)
    have "to_int_mod_ring (x ^ Suc n) = to_int_mod_ring (x * x ^ n)" by auto
    also have "... = to_int_mod_ring x * to_int_mod_ring (x ^ n) mod CARD('a)"
      unfolding to_int_mod_ring_def using times_mod_ring.rep_eq by auto
    also have "... = to_int_mod_ring x * (to_int_mod_ring x ^ n mod CARD('a)) mod CARD('a)"
      using Suc.hyps by auto
    also have "... = to_int_mod_ring x ^ Suc n mod int CARD('a)"
      by (simp add: mod_simps)
    finally show ?case ..
  qed
qed

lemma dvd_mod_ring_transfer[transfer_rule]:
"((pcr_mod_ring :: int  'a :: nontriv mod_ring  bool) ===>
  (pcr_mod_ring :: int  'a mod_ring  bool) ===> (=))
  (λ i j. k  {0..<int CARD('a)}. j = i * k mod int CARD('a)) (dvd)"
proof (unfold pcr_mod_ring_to_int_mod_ring, intro rel_funI iffI)
  fix x y :: "'a mod_ring" and i j
  assume i: "i = to_int_mod_ring x" and j: "j = to_int_mod_ring y"
  { assume "x dvd y"
    then obtain z where "y = x * z" by (elim dvdE, auto)
    then have "j = i * to_int_mod_ring z mod CARD('a)" by (unfold i j, transfer)
    with range_to_int_mod_ring
    show "k  {0..<int CARD('a)}. j = i * k mod CARD('a)" by auto
  }
  assume "k  {0..<int CARD('a)}. j = i * k mod CARD('a)"
  then obtain k where k: "k  {0..<int CARD('a)}" and dvd: "j = i * k mod CARD('a)" by auto
  from k have "to_int_mod_ring (of_int k :: 'a mod_ring) = k" by (transfer, auto)
  also from dvd have "j = i * ... mod CARD('a)" by auto
  finally have "y = x * (of_int k :: 'a mod_ring)" unfolding i j using k by (transfer, auto)
  then show "x dvd y" by auto
qed

lemma Rep_mod_ring_mod[simp]: "Rep_mod_ring (a :: 'a :: nontriv mod_ring) mod CARD('a) = Rep_mod_ring a"
  using Rep_mod_ring[where 'a = 'a] by auto

subsection ‹Finite Fields›

text ‹When the domain is prime, the ring becomes a field›

class prime_card = assumes prime_card: "prime (CARD('a))"
begin
lemma prime_card_int: "prime (int (CARD('a)))" using prime_card by auto

subclass nontriv using prime_card prime_gt_1_nat by (intro_classes,auto)
end

instantiation mod_ring :: (prime_card) field
begin
 
definition inverse_mod_ring :: "'a mod_ring  'a mod_ring" where
  "inverse_mod_ring x = (if x = 0 then 0 else x ^ (nat (CARD('a) - 2)))"

definition divide_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring"  where
  "divide_mod_ring x y = x * ((λc. if c = 0 then 0 else c ^ (nat (CARD('a) - 2))) y)" 

instance
proof
  fix a b c::"'a mod_ring"
  show "inverse 0 = (0::'a mod_ring)" by (simp add: inverse_mod_ring_def)
  show "a div b = a * inverse b" 
    unfolding inverse_mod_ring_def by (transfer', simp add: divide_mod_ring_def)
  show "a  0  inverse a * a = 1"
  proof (unfold inverse_mod_ring_def, transfer)
    let ?p="CARD('a)"
    fix x
    assume x: "x  {0..<int CARD('a)}" and x0: "x  0"
    have p0': "0?p" by auto
    have "¬ ?p dvd x"
      using x x0 zdvd_imp_le by fastforce
    then have "¬ CARD('a) dvd nat ¦x¦"
      by simp
    with x have "¬ CARD('a) dvd nat x"
      by simp
    have rw: "x ^ nat (int (?p - 2)) * x = x ^ nat (?p - 1)"
    proof -
      have p2: "0  int (?p-2)" using x by simp
      have card_rw: "(CARD('a) - Suc 0) = nat (1 + int (CARD('a) - 2))" 
        using nat_eq_iff x x0 by auto
      have "x ^ nat (?p - 2)*x = x ^ (Suc (nat (?p - 2)))" by simp
      also have "... = x ^ (nat (?p - 1))"
        using Suc_nat_eq_nat_zadd1[OF p2] card_rw by auto
      finally show ?thesis .
    qed
    have "[int (nat x ^ (CARD('a) - 1)) = int 1] (mod CARD('a))"
      using fermat_theorem [OF prime_card ¬ CARD('a) dvd nat x]
      by (simp only: cong_def cong_def of_nat_mod [symmetric])
    then have *: "[x ^ (CARD('a) - 1) = 1] (mod CARD('a))"
      using x by auto
    have "x ^ (CARD('a) - 2) mod CARD('a) * x mod CARD('a) 
      = (x ^ nat (CARD('a) - 2) * x) mod CARD('a)" by (simp add: mod_simps)
    also have "... =  (x ^ nat (?p - 1) mod ?p)" unfolding rw by simp
    also have "... = (x ^ (nat ?p - 1) mod ?p)" using p0' by (simp add: nat_diff_distrib')
    also have "... = 1"
      using * by (simp add: cong_def)
    finally show "(if x = 0 then 0 else x ^ nat (int (CARD('a) - 2)) mod CARD('a)) * x mod CARD('a) = 1"
      using x0 by auto
  qed
qed
end

instantiation mod_ring :: (prime_card) "{normalization_euclidean_semiring, euclidean_ring}"
begin

definition modulo_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring" where "modulo_mod_ring x y = (if y = 0 then x else 0)"
definition normalize_mod_ring :: "'a mod_ring  'a mod_ring" where "normalize_mod_ring x = (if x = 0 then 0 else 1)" 
definition unit_factor_mod_ring :: "'a mod_ring  'a mod_ring" where "unit_factor_mod_ring x = x" 
definition euclidean_size_mod_ring :: "'a mod_ring  nat" where "euclidean_size_mod_ring x = (if x = 0 then 0 else 1)" 

instance
proof (intro_classes)
  fix a :: "'a mod_ring" show "a  0  unit_factor a dvd 1"
    unfolding dvd_def unit_factor_mod_ring_def by (intro exI[of _ "inverse a"], auto)
qed (auto simp: normalize_mod_ring_def unit_factor_mod_ring_def modulo_mod_ring_def
     euclidean_size_mod_ring_def field_simps)
end

instantiation mod_ring :: (prime_card) euclidean_ring_gcd
begin

definition gcd_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring" where "gcd_mod_ring = Euclidean_Algorithm.gcd"
definition lcm_mod_ring :: "'a mod_ring  'a mod_ring  'a mod_ring" where "lcm_mod_ring = Euclidean_Algorithm.lcm"
definition Gcd_mod_ring :: "'a mod_ring set  'a mod_ring" where "Gcd_mod_ring = Euclidean_Algorithm.Gcd"
definition Lcm_mod_ring :: "'a mod_ring set  'a mod_ring" where "Lcm_mod_ring = Euclidean_Algorithm.Lcm"

instance by (intro_classes, auto simp: gcd_mod_ring_def lcm_mod_ring_def Gcd_mod_ring_def Lcm_mod_ring_def)
end

instantiation mod_ring :: (prime_card) unique_euclidean_ring
begin

definition [simp]: "division_segment_mod_ring (x :: 'a mod_ring) = (1 :: 'a mod_ring)"

instance by intro_classes (auto simp: euclidean_size_mod_ring_def split: if_splits)

end

instance mod_ring :: (prime_card) field_gcd
  by intro_classes auto


lemma surj_of_nat_mod_ring: " i. i < CARD('a :: prime_card)  (x :: 'a mod_ring) = of_nat i" 
  by (rule exI[of _ "nat (to_int_mod_ring x)"], unfold of_nat_of_int_mod_ring o_def,
  subst nat_0_le, transfer, simp, simp, transfer, auto) 

lemma of_nat_0_mod_ring_dvd: assumes x: "of_nat x = (0 :: 'a ::prime_card mod_ring)"
  shows "CARD('a) dvd x" 
proof -
  let ?x = "of_nat x :: int" 
  from x have "of_int_mod_ring ?x = (0 :: 'a mod_ring)" by (fold of_int_of_int_mod_ring, simp)
  hence "?x mod CARD('a) = 0" by (transfer, auto)
  hence "x mod CARD('a) = 0" by presburger
  thus ?thesis unfolding mod_eq_0_iff_dvd .
qed

end

Theory Arithmetic_Record_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹Arithmetics via Records›

text ‹We create a locale for rings and fields based on a record 
  that includes all the necessary operations.›

theory Arithmetic_Record_Based
imports 
  "HOL-Library.More_List"
  "HOL-Computational_Algebra.Euclidean_Algorithm"
begin
datatype 'a arith_ops_record = Arith_Ops_Record
  (zero : 'a)
  (one  : 'a)
  (plus : "'a  'a  'a")
  (times : "'a  'a  'a")
  (minus : "'a  'a  'a")
  (uminus : "'a  'a")
  (divide : "'a  'a  'a")
  (inverse : "'a  'a")
  ("modulo" : "'a  'a  'a")
  (normalize : "'a  'a")
  (unit_factor : "'a  'a")
  (of_int : "int  'a")
  (to_int : "'a  int")
  (DP : "'a  bool")

hide_const (open) 
  zero 
  one  
  plus 
  times
  minus
  uminus 
  divide
  inverse
  modulo
  normalize
  unit_factor
  of_int
  to_int
  DP

fun listprod_i :: "'i arith_ops_record  'i list  'i" where
  "listprod_i ops (x # xs) = arith_ops_record.times ops x (listprod_i ops xs)"
| "listprod_i ops [] = arith_ops_record.one ops"

locale arith_ops = fixes ops :: "'i arith_ops_record" (structure)
begin

abbreviation (input) zero where "zero  arith_ops_record.zero ops"
abbreviation (input) one where "one  arith_ops_record.one ops"
abbreviation (input) plus where "plus  arith_ops_record.plus ops"
abbreviation (input) times where "times  arith_ops_record.times ops"
abbreviation (input) minus where "minus  arith_ops_record.minus ops"
abbreviation (input) uminus where "uminus  arith_ops_record.uminus ops"
abbreviation (input) divide where "divide  arith_ops_record.divide ops"
abbreviation (input) inverse where "inverse  arith_ops_record.inverse ops"
abbreviation (input) modulo where "modulo  arith_ops_record.modulo ops"
abbreviation (input) normalize where "normalize  arith_ops_record.normalize ops"
abbreviation (input) unit_factor where "unit_factor  arith_ops_record.unit_factor ops"
abbreviation (input) DP where "DP  arith_ops_record.DP ops"


partial_function (tailrec) gcd_eucl_i :: "'i  'i  'i" where
  "gcd_eucl_i a b = (if b = zero 
    then normalize a else gcd_eucl_i b (modulo a b))"

partial_function (tailrec) euclid_ext_aux_i :: "'i  'i  'i  'i  'i  'i  ('i × 'i) × 'i" where
  "euclid_ext_aux_i s' s t' t r' r = (
     if r = zero then let c = divide one (unit_factor r') in ((times s' c, times t' c), normalize r')
     else let q = divide r' r
          in  euclid_ext_aux_i s (minus s' (times q s)) t (minus t' (times q t)) r (modulo r' r))"

abbreviation (input) euclid_ext_i :: "'i  'i  ('i × 'i) × 'i" where 
  "euclid_ext_i  euclid_ext_aux_i one zero zero one" 

end

declare arith_ops.gcd_eucl_i.simps[code]
declare arith_ops.euclid_ext_aux_i.simps[code]
 
unbundle lifting_syntax
                                                       
locale ring_ops = arith_ops ops for ops :: "'i arith_ops_record" +
  fixes R :: "'i  'a :: comm_ring_1  bool" 
  assumes bi_unique[transfer_rule]: "bi_unique R" 
  and right_total[transfer_rule]: "right_total R"
  and zero[transfer_rule]: "R zero 0"
  and one[transfer_rule]: "R one 1"
  and plus[transfer_rule]: "(R ===> R ===> R) plus (+)"
  and minus[transfer_rule]: "(R ===> R ===> R) minus (-)"
  and uminus[transfer_rule]: "(R ===> R) uminus Groups.uminus"
  and times[transfer_rule]: "(R ===> R ===> R) times ((*))"
  and eq[transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
  and DPR[transfer_domain_rule]: "Domainp R = DP" 
begin
lemma left_right_unique[transfer_rule]: "left_unique R" "right_unique R"
  using bi_unique unfolding bi_unique_def left_unique_def right_unique_def by auto

lemma listprod_i[transfer_rule]: "(list_all2 R ===> R) (listprod_i ops) prod_list"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  thus ?case 
  proof (induct xs ys rule: list_all2_induct)
    case (Cons x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one)
qed
end

locale idom_ops = ring_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i  'a :: idom  bool"

locale idom_divide_ops = idom_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i  'a :: idom_divide  bool" +
  assumes divide[transfer_rule]: "(R ===> R ===> R) divide Rings.divide"  

locale euclidean_semiring_ops = idom_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i  'a :: {idom,normalization_euclidean_semiring}  bool"  +
  assumes modulo[transfer_rule]: "(R ===> R ===> R) modulo (mod)"
    and normalize[transfer_rule]: "(R ===> R) normalize Rings.normalize"
    and unit_factor[transfer_rule]: "(R ===> R) unit_factor Rings.unit_factor"
begin
lemma gcd_eucl_i [transfer_rule]: "(R ===> R ===> R) gcd_eucl_i Euclidean_Algorithm.gcd" 
proof (intro rel_funI, goal_cases)
  case (1 x X y Y)
  thus ?case
  proof (induct X Y arbitrary: x y rule: Euclidean_Algorithm.gcd.induct)
    case (1 X Y x y)
    note [transfer_rule] = 1(2-)
    note simps = gcd_eucl_i.simps[of x y] Euclidean_Algorithm.gcd.simps[of X Y]
    have eq: "(y = zero) = (Y = 0)" by transfer_prover
    show ?case
    proof (cases "Y = 0")
      case True
      hence *: "y = zero" using eq by simp
      have "R (normalize x) (Rings.normalize X)" by transfer_prover
      thus ?thesis unfolding simps unfolding True * by simp
    next
      case False
      with eq have yz: "y  zero" by simp
      have "R (gcd_eucl_i y (modulo x y)) (Euclidean_Algorithm.gcd Y (X mod Y))"
        by (rule 1(1)[OF False], transfer_prover+)
      thus ?thesis unfolding simps using False yz by simp
    qed
  qed
qed
end

locale euclidean_ring_ops = euclidean_semiring_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i  'a :: {idom,euclidean_ring_gcd}  bool"  +
  assumes divide[transfer_rule]: "(R ===> R ===> R) divide (div)"
begin
lemma euclid_ext_aux_i[transfer_rule]: 
  "(R ===> R ===> R ===> R ===> R ===> R ===> rel_prod (rel_prod R R) R) euclid_ext_aux_i euclid_ext_aux"
proof (intro rel_funI, goal_cases)
  case (1 z Z a A b B c C x X y Y)
  thus ?case
  proof (induct Z A B C X Y arbitrary: z a b c x y rule: euclid_ext_aux.induct)
    case (1 Z A B C X Y z a b c x y)
    note [transfer_rule] = 1(2-)
    note simps = euclid_ext_aux_i.simps[of z a b c x y] euclid_ext_aux.simps[of Z A B C X Y]
    have eq: "(y = zero) = (Y = 0)" by transfer_prover
    show ?case
    proof (cases "Y = 0")
      case True
      hence *: "(y = zero) = True" "(Y = 0) = True" using eq by auto
      show ?thesis unfolding simps unfolding * if_True
        by transfer_prover
    next
      case False
      hence *: "(y = zero) = False" "(Y = 0) = False" using eq by auto
      have XY: "R (modulo x y) (X mod Y)" by transfer_prover
      have YA: "R (minus z (times (divide x y) a)) (Z - X div Y * A)" by transfer_prover
      have YC: "R (minus b (times (divide x y) c)) (B - X div Y * C)" by transfer_prover
      note [transfer_rule] = 1(1)[OF False refl 1(3) YA 1(5) YC 1(7) XY]

      show ?thesis unfolding simps * if_False Let_def by transfer_prover
    qed
  qed
qed

lemma euclid_ext_i [transfer_rule]:
  "(R ===> R ===> rel_prod (rel_prod R R) R) euclid_ext_i euclid_ext"
  by transfer_prover

end

locale field_ops = idom_divide_ops ops R + euclidean_semiring_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i  'a :: {field_gcd}  bool" +
  assumes inverse[transfer_rule]: "(R ===> R) inverse Fields.inverse"
  

lemma nth_default_rel[transfer_rule]: "(S ===> list_all2 S ===> (=) ===> S) nth_default nth_default"
proof (intro rel_funI, clarify, goal_cases)
  case (1 x y xs ys _ n)
  from 1(2) show ?case
  proof (induct arbitrary: n)
    case Nil
    thus ?case using 1(1) by simp
  next
    case (Cons x y xs ys n)
    thus ?case by (cases n, auto)
  qed
qed

lemma strip_while_rel[transfer_rule]: 
  "((A ===> (=)) ===> list_all2 A ===> list_all2 A) strip_while strip_while"
  unfolding strip_while_def[abs_def] by transfer_prover

lemma list_all2_last[simp]: "list_all2 A (xs @ [x]) (ys @ [y])  list_all2 A xs ys  A x y"
proof (cases "length xs = length ys")
  case True
  show ?thesis by (simp add: list_all2_append[OF True])
next
  case False
  note len = list_all2_lengthD[of A]
  from len[of xs ys] len[of "xs @ [x]" "ys @ [y]"] False
  show ?thesis by auto 
qed  


end

Theory Finite_Field_Record_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Finite Fields›

text ‹We provide four implementations for $GF(p)$ -- the field with $p$ elements for some
  prime $p$ -- one by int, one by integers, one by 32-bit numbers and one 64-bit implementation. 
  Correctness of the implementations is proven by
  transfer rules to the type-based version of $GF(p)$.›

theory Finite_Field_Record_Based
imports
  Finite_Field
  Arithmetic_Record_Based
  Native_Word.Uint32 
  Native_Word.Uint64
  Native_Word.Code_Target_Bits_Int
  "HOL-Library.Code_Target_Numeral"  
begin

(* mod on standard case which can immediately be mapped to 
   target languages without considering special cases *)
definition mod_nonneg_pos :: "integer  integer  integer" where
  "x  0  y > 0  mod_nonneg_pos x y = (x mod y)"
  
code_printing ― ‹FIXME illusion of partiality›
  constant mod_nonneg_pos 
        (SML) "IntInf.mod/ ( _,/ _ )"
    and (Eval) "IntInf.mod/ ( _,/ _ )"
    and (OCaml) "Z.rem"
    and (Haskell) "Prelude.mod/ ( _ )/ ( _ )"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ (k '% l))"

definition mod_nonneg_pos_int :: "int  int  int" where
  "mod_nonneg_pos_int x y = int_of_integer (mod_nonneg_pos (integer_of_int x) (integer_of_int y))" 

lemma mod_nonneg_pos_int[simp]: "x  0  y > 0  mod_nonneg_pos_int x y = (x mod y)" 
  unfolding mod_nonneg_pos_int_def using mod_nonneg_pos_def by simp

context
  fixes p :: int
begin
definition plus_p :: "int  int  int" where
  "plus_p x y  let z = x + y in if z  p then z - p else z"

definition minus_p :: "int  int  int" where
  "minus_p x y  if y  x then x - y else x + p - y"

definition uminus_p :: "int  int" where
  "uminus_p x = (if x = 0 then 0 else p - x)"

definition mult_p :: "int  int  int" where
  "mult_p x y = (mod_nonneg_pos_int (x * y) p)"

fun power_p :: "int  nat  int" where
  "power_p x n = (if n = 0 then 1 else
    let (d,r) = Divides.divmod_nat n 2;
       rec = power_p (mult_p x x) d in
    if r = 0 then rec else mult_p rec x)"

text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.›

definition inverse_p :: "int  int" where
  "inverse_p x = (if x = 0 then 0 else power_p x (nat (p - 2)))"

definition divide_p :: "int  int  int"  where
  "divide_p x y = mult_p x (inverse_p y)"

definition finite_field_ops_int :: "int arith_ops_record" where
  "finite_field_ops_int  Arith_Ops_Record
      0
      1
      plus_p
      mult_p
      minus_p
      uminus_p
      divide_p
      inverse_p
      (λ x y . if y = 0 then x else 0)
      (λ x . if x = 0 then 0 else 1)
      (λ x . x)
      (λ x . x)
      (λ x . x)
      (λ x. 0  x  x < p)"

end

context
  fixes p :: uint32
begin
definition plus_p32 :: "uint32  uint32  uint32" where
  "plus_p32 x y  let z = x + y in if z  p then z - p else z"

definition minus_p32 :: "uint32  uint32  uint32" where
  "minus_p32 x y  if y  x then x - y else (x + p) - y"

definition uminus_p32 :: "uint32  uint32" where
  "uminus_p32 x = (if x = 0 then 0 else p - x)"

definition mult_p32 :: "uint32  uint32  uint32" where
  "mult_p32 x y = (x * y mod p)"

lemma int_of_uint32_shift: "int_of_uint32 (shiftr n k) = (int_of_uint32 n) div (2 ^ k)" 
  apply transfer
  apply transfer
  apply (simp add: take_bit_drop_bit min_def)
  apply (simp add: drop_bit_eq_div)
  done

lemma int_of_uint32_0_iff: "int_of_uint32 n = 0  n = 0" 
  by (transfer, rule uint_0_iff)
  
lemma int_of_uint32_0: "int_of_uint32 0 = 0" unfolding int_of_uint32_0_iff by simp

lemma int_of_uint32_ge_0: "int_of_uint32 n  0" 
  by (transfer, auto)

lemma two_32: "2 ^ LENGTH(32) = (4294967296 :: int)" by simp

lemma int_of_uint32_plus: "int_of_uint32 (x + y) = (int_of_uint32 x + int_of_uint32 y) mod 4294967296" 
  by (transfer, unfold uint_word_ariths two_32, rule refl)  

lemma int_of_uint32_minus: "int_of_uint32 (x - y) = (int_of_uint32 x - int_of_uint32 y) mod 4294967296" 
  by (transfer, unfold uint_word_ariths two_32, rule refl)  

lemma int_of_uint32_mult: "int_of_uint32 (x * y) = (int_of_uint32 x * int_of_uint32 y) mod 4294967296" 
  by (transfer, unfold uint_word_ariths two_32, rule refl)  

lemma int_of_uint32_mod: "int_of_uint32 (x mod y) = (int_of_uint32 x mod int_of_uint32 y)" 
  by (transfer, unfold uint_mod two_32, rule refl)  

lemma int_of_uint32_inv: "0  x  x < 4294967296  int_of_uint32 (uint32_of_int x) = x"
  by transfer (simp add: take_bit_int_eq_self)

function power_p32 :: "uint32  uint32  uint32" where
  "power_p32 x n = (if n = 0 then 1 else
    let rec = power_p32 (mult_p32 x x) (shiftr n 1) in
    if n AND 1 = 0 then rec else mult_p32 rec x)"
  by pat_completeness auto

termination 
proof -
  {
    fix n :: uint32
    assume "n  0" 
    with int_of_uint32_ge_0[of n] int_of_uint32_0_iff[of n] have "int_of_uint32 n > 0" by auto
    hence "0 < int_of_uint32 n" "int_of_uint32 n div 2 < int_of_uint32 n" by auto
  } note * = this
  show ?thesis
    by (relation "measure (λ (x,n). nat (int_of_uint32 n))", auto simp: int_of_uint32_shift *) 
qed

text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.›

definition inverse_p32 :: "uint32  uint32" where
  "inverse_p32 x = (if x = 0 then 0 else power_p32 x (p - 2))"

definition divide_p32 :: "uint32  uint32  uint32"  where
  "divide_p32 x y = mult_p32 x (inverse_p32 y)"

definition finite_field_ops32 :: "uint32 arith_ops_record" where
  "finite_field_ops32  Arith_Ops_Record
      0
      1
      plus_p32
      mult_p32
      minus_p32
      uminus_p32
      divide_p32
      inverse_p32
      (λ x y . if y = 0 then x else 0)
      (λ x . if x = 0 then 0 else 1)
      (λ x . x)
      uint32_of_int
      int_of_uint32
      (λ x. 0  x  x < p)"
end 

lemma shiftr_uint32_code [code_unfold]: "drop_bit 1 x = (uint32_shiftr x 1)"
  by (simp add: uint32_shiftr_def shiftr_eq_drop_bit)

(* ******************************************************************************** *)
subsubsection ‹Transfer Relation›
locale mod_ring_locale =
  fixes p :: int and ty :: "'a :: nontriv itself"
  assumes p: "p = int CARD('a)"
begin
lemma nat_p: "nat p = CARD('a)" unfolding p by simp
lemma p2: "p  2" unfolding p using nontriv[where 'a = 'a] by auto
lemma p2_ident: "int (CARD('a) - 2) = p - 2" using p2 unfolding p by simp

definition mod_ring_rel :: "int  'a mod_ring  bool" where
  "mod_ring_rel x x' = (x = to_int_mod_ring x')"

(* domain transfer rules *)
lemma Domainp_mod_ring_rel [transfer_domain_rule]:
  "Domainp (mod_ring_rel) = (λ v. v  {0 ..< p})"
proof -
  {
    fix v :: int
    assume *: "0  v" "v < p"
    have "Domainp mod_ring_rel v"
    proof
      show "mod_ring_rel v (of_int_mod_ring v)" unfolding mod_ring_rel_def using * p by auto
    qed
  } note * = this
  show ?thesis
    by (intro ext iffI, insert range_to_int_mod_ring[where 'a = 'a] *, auto simp: mod_ring_rel_def p)
qed

(* left/right/bi-unique *)
lemma bi_unique_mod_ring_rel [transfer_rule]:
  "bi_unique mod_ring_rel" "left_unique mod_ring_rel" "right_unique mod_ring_rel"
  unfolding mod_ring_rel_def bi_unique_def left_unique_def right_unique_def
  by auto

(* left/right-total *)
lemma right_total_mod_ring_rel [transfer_rule]: "right_total mod_ring_rel"
  unfolding mod_ring_rel_def right_total_def by simp


(* ************************************************************************************ *)
subsubsection ‹Transfer Rules›

(* 0 / 1 *)
lemma mod_ring_0[transfer_rule]: "mod_ring_rel 0 0" unfolding mod_ring_rel_def by simp
lemma mod_ring_1[transfer_rule]: "mod_ring_rel 1 1" unfolding mod_ring_rel_def by simp

(* addition *)
lemma plus_p_mod_def: assumes x: "x  {0 ..< p}" and y: "y  {0 ..< p}"
  shows "plus_p p x y = ((x + y) mod p)"
proof (cases "p  x + y")
  case False
  thus ?thesis using x y unfolding plus_p_def Let_def by auto
next
  case True
  from True x y have *: "p > 0" "0  x + y - p" "x + y - p < p" by auto
  from True have id: "plus_p p x y = x + y - p" unfolding plus_p_def by auto
  show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
qed

lemma mod_ring_plus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (plus_p p) (+)"
proof -
  {
    fix x y :: "'a mod_ring"
    have "plus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x + y)"
      by (transfer, subst plus_p_mod_def, auto, auto simp: p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* subtraction *)
lemma minus_p_mod_def: assumes x: "x  {0 ..< p}" and y: "y  {0 ..< p}"
  shows "minus_p p x y = ((x - y) mod p)"
proof (cases "x - y < 0")
  case False
  thus ?thesis using x y unfolding minus_p_def Let_def by auto
next
  case True
  from True x y have *: "p > 0" "0  x - y + p" "x - y + p < p" by auto
  from True have id: "minus_p p x y = x - y + p" unfolding minus_p_def by auto
  show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
qed

lemma mod_ring_minus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (minus_p p) (-)"
proof -
  {
    fix x y :: "'a mod_ring"
    have "minus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x - y)"
      by (transfer, subst minus_p_mod_def, auto simp: p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* unary minus *)
lemma mod_ring_uminus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (uminus_p p) uminus"
proof -
  {
    fix x :: "'a mod_ring"
    have "uminus_p p (to_int_mod_ring x) = to_int_mod_ring (uminus x)"
      by (transfer, auto simp: uminus_p_def p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* multiplication *)
lemma mod_ring_mult[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (mult_p p) ((*))"
proof -
  {
    fix x y :: "'a mod_ring"
    have "mult_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x * y)"
      by (transfer, auto simp: mult_p_def p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* equality *)
lemma mod_ring_eq[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> (=)) (=) (=)"
  by (intro rel_funI, auto simp: mod_ring_rel_def)

(* power *)
lemma mod_ring_power[transfer_rule]: "(mod_ring_rel ===> (=) ===> mod_ring_rel) (power_p p) (^)"
proof (intro rel_funI, clarify, unfold binary_power[symmetric], goal_cases)
  fix x y n
  assume xy: "mod_ring_rel x y"
  from xy show "mod_ring_rel (power_p p x n) (binary_power y n)"
  proof (induct y n arbitrary: x rule: binary_power.induct)
    case (1 x n y)
    note 1(2)[transfer_rule]
    show ?case
    proof (cases "n = 0")
      case True
      thus ?thesis by (simp add: mod_ring_1)
    next
      case False
      obtain d r where id: "Divides.divmod_nat n 2 = (d,r)" by force
      let ?int = "power_p p (mult_p p y y) d"
      let ?gfp = "binary_power (x * x) d"
      from False have id': "?thesis = (mod_ring_rel
         (if r = 0 then ?int else mult_p p ?int y)
         (if r = 0 then ?gfp else ?gfp * x))"
        unfolding power_p.simps[of _ _ n] binary_power.simps[of _ n] Let_def id split by simp
      have [transfer_rule]: "mod_ring_rel ?int ?gfp"
        by (rule 1(1)[OF False refl id[symmetric]], transfer_prover)
      show ?thesis unfolding id' by transfer_prover
    qed
  qed
qed

declare power_p.simps[simp del]

lemma ring_finite_field_ops_int: "ring_ops (finite_field_ops_int p) mod_ring_rel"
  by (unfold_locales, auto simp:
  finite_field_ops_int_def
  bi_unique_mod_ring_rel
  right_total_mod_ring_rel
  mod_ring_plus
  mod_ring_minus
  mod_ring_uminus
  mod_ring_mult
  mod_ring_eq
  mod_ring_0
  mod_ring_1
  Domainp_mod_ring_rel)
end

locale prime_field = mod_ring_locale p ty for p and ty :: "'a :: prime_card itself"
begin

lemma prime: "prime p" unfolding p using prime_card[where 'a = 'a] by simp

(* mod *)
lemma mod_ring_mod[transfer_rule]:
 "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) ((λ x y. if y = 0 then x else 0)) (mod)"
proof -
  {
    fix x y :: "'a mod_ring"
    have "(if to_int_mod_ring y = 0 then to_int_mod_ring x else 0) = to_int_mod_ring (x mod y)"
      unfolding modulo_mod_ring_def by auto
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed

(* normalize *)
lemma mod_ring_normalize[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) ((λ x. if x = 0 then 0 else 1)) normalize"
proof -
  {
    fix x :: "'a mod_ring"
    have "(if to_int_mod_ring x = 0 then 0 else 1) = to_int_mod_ring (normalize x)"
      unfolding normalize_mod_ring_def by auto
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed

(* unit_factor *)
lemma mod_ring_unit_factor[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (λ x. x) unit_factor"
proof -
  {
    fix x :: "'a mod_ring"
    have "to_int_mod_ring x = to_int_mod_ring (unit_factor x)"
      unfolding unit_factor_mod_ring_def by auto
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed

(* inverse *)
lemma mod_ring_inverse[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (inverse_p p) inverse"
proof (intro rel_funI)
  fix x y
  assume [transfer_rule]: "mod_ring_rel x y"
  show "mod_ring_rel (inverse_p p x) (inverse y)"
    unfolding inverse_p_def inverse_mod_ring_def
    apply (transfer_prover_start)
    apply (transfer_step)+
    apply (unfold p2_ident)
    apply (rule refl)
    done
qed

(* division *)
lemma mod_ring_divide[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel)
  (divide_p p) (/)"
  unfolding divide_p_def[abs_def] divide_mod_ring_def[abs_def] inverse_mod_ring_def[symmetric]
  by transfer_prover

lemma mod_ring_rel_unsafe: assumes "x < CARD('a)"
  shows "mod_ring_rel (int x) (of_nat x)" "0 < x  of_nat x  (0 :: 'a mod_ring)"
proof -
  have id: "of_nat x = (of_int (int x) :: 'a mod_ring)" by simp
  show "mod_ring_rel (int x) (of_nat x)" "0 < x  of_nat x  (0 :: 'a mod_ring)" unfolding id
  unfolding mod_ring_rel_def
  proof (auto simp add: assms of_int_of_int_mod_ring)
    assume "0 < x" with assms
    have "of_int_mod_ring (int x)  (0 :: 'a mod_ring)"
      by (metis (no_types) less_imp_of_nat_less less_irrefl of_nat_0_le_iff of_nat_0_less_iff to_int_mod_ring_hom.hom_zero to_int_mod_ring_of_int_mod_ring)
    thus "of_int_mod_ring (int x) = (0 :: 'a mod_ring)  False" by blast
  qed
qed

lemma finite_field_ops_int: "field_ops (finite_field_ops_int p) mod_ring_rel"
  by (unfold_locales, auto simp:
  finite_field_ops_int_def
  bi_unique_mod_ring_rel
  right_total_mod_ring_rel
  mod_ring_divide
  mod_ring_plus
  mod_ring_minus
  mod_ring_uminus
  mod_ring_inverse
  mod_ring_mod
  mod_ring_unit_factor
  mod_ring_normalize
  mod_ring_mult
  mod_ring_eq
  mod_ring_0
  mod_ring_1
  Domainp_mod_ring_rel)

end

text ‹Once we have proven the soundness of the implementation, we do not care any longer
  that @{typ "'a mod_ring"} has been defined internally via lifting. Disabling the transfer-rules
  will hide the internal definition in further applications of transfer.›
lifting_forget mod_ring.lifting

text ‹For soundness of the 32-bit implementation, we mainly prove that this implementation
  implements the int-based implementation of the mod-ring.›
context mod_ring_locale
begin

context fixes pp :: "uint32" 
  assumes ppp: "p = int_of_uint32 pp" 
  and small: "p  65535" 
begin

lemmas uint32_simps = 
  int_of_uint32_0
  int_of_uint32_plus 
  int_of_uint32_minus
  int_of_uint32_mult
  

definition urel32 :: "uint32  int  bool" where "urel32 x y = (y = int_of_uint32 x  y < p)" 

definition mod_ring_rel32 :: "uint32  'a mod_ring  bool" where
  "mod_ring_rel32 x y = ( z. urel32 x z  mod_ring_rel z y)" 

lemma urel32_0: "urel32 0 0" unfolding urel32_def using p2 by (simp, transfer, simp)

lemma urel32_1: "urel32 1 1" unfolding urel32_def using p2 by (simp, transfer, simp)

lemma le_int_of_uint32: "(x  y) = (int_of_uint32 x  int_of_uint32 y)" 
  by (transfer, simp add: word_le_def)

lemma urel32_plus: assumes "urel32 x y" "urel32 x' y'"
  shows "urel32 (plus_p32 pp x x') (plus_p p y y')"
proof -    
  let ?x = "int_of_uint32 x" 
  let ?x' = "int_of_uint32 x'" 
  let ?p = "int_of_uint32 pp" 
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x'  p" unfolding urel32_def by auto
  have le: "(pp  x + x') = (?p  ?x + ?x')" unfolding le_int_of_uint32
    using rel small by (auto simp: uint32_simps)
  show ?thesis
  proof (cases "?p  ?x + ?x'")
    case True
    hence True: "(?p  ?x + ?x') = True" by simp
    show ?thesis unfolding id 
      using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def 
      unfolding ppp le True if_True
      using True by (auto simp: uint32_simps)
  next
    case False
    hence False: "(?p  ?x + ?x') = False" by simp
    show ?thesis unfolding id 
      using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def 
      unfolding ppp le False if_False
      using False by (auto simp: uint32_simps)
  qed
qed
  
lemma urel32_minus: assumes "urel32 x y" "urel32 x' y'"
  shows "urel32 (minus_p32 pp x x') (minus_p p y y')"
proof -    
  let ?x = "int_of_uint32 x" 
  let ?x' = "int_of_uint32 x'" 
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x'  p" unfolding urel32_def by auto
  have le: "(x'  x) = (?x'  ?x)" unfolding le_int_of_uint32
    using rel small by (auto simp: uint32_simps)
  show ?thesis
  proof (cases "?x'  ?x")
    case True
    hence True: "(?x'  ?x) = True" by simp
    show ?thesis unfolding id 
      using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def 
      unfolding ppp le True if_True
      using True by (auto simp: uint32_simps)
  next
    case False
    hence False: "(?x'  ?x) = False" by simp
    show ?thesis unfolding id 
      using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def 
      unfolding ppp le False if_False
      using False by (auto simp: uint32_simps)
  qed
qed

lemma urel32_uminus: assumes "urel32 x y"
  shows "urel32 (uminus_p32 pp x) (uminus_p p y)"
proof -    
  let ?x = "int_of_uint32 x"  
  from assms int_of_uint32_ge_0 have id: "y = ?x" 
    and rel: "0  ?x" "?x < p" 
      unfolding urel32_def by auto
  have le: "(x = 0) = (?x = 0)" unfolding int_of_uint32_0_iff
    using rel small by (auto simp: uint32_simps)
  show ?thesis
  proof (cases "?x = 0")
    case True
    hence True: "(?x = 0) = True" by simp
    show ?thesis unfolding id 
      using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def 
      unfolding ppp le True if_True
      using True by (auto simp: uint32_simps)
  next
    case False
    hence False: "(?x = 0) = False" by simp
    show ?thesis unfolding id 
      using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def 
      unfolding ppp le False if_False
      using False by (auto simp: uint32_simps)
  qed
qed

lemma urel32_mult: assumes "urel32 x y" "urel32 x' y'"
  shows "urel32 (mult_p32 pp x x') (mult_p p y y')"
proof -    
  let ?x = "int_of_uint32 x" 
  let ?x' = "int_of_uint32 x'" 
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x' < p" unfolding urel32_def by auto
  from rel have "?x * ?x' < p * p" by (metis mult_strict_mono') 
  also have "  65536 * 65536"
    by (rule mult_mono, insert p2 small, auto)
  finally have le: "?x * ?x' < 4294967296" by simp
  show ?thesis unfolding id
      using small rel unfolding mult_p32_def mult_p_def Let_def urel32_def 
      unfolding ppp 
    by (auto simp: uint32_simps, unfold int_of_uint32_mod int_of_uint32_mult, 
        subst mod_pos_pos_trivial[of _ 4294967296], insert le, auto)
qed

lemma urel32_eq: assumes "urel32 x y" "urel32 x' y'" 
  shows "(x = x') = (y = y')" 
proof -    
  let ?x = "int_of_uint32 x" 
  let ?x' = "int_of_uint32 x'" 
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
    unfolding urel32_def by auto
  show ?thesis unfolding id by (transfer, transfer) rule
qed

lemma urel32_normalize: 
assumes x: "urel32 x y"
shows "urel32 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
 unfolding urel32_eq[OF x urel32_0] using urel32_0 urel32_1 by auto

lemma urel32_mod: 
assumes x: "urel32 x x'" and y: "urel32 y y'" 
shows "urel32 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
  unfolding urel32_eq[OF y urel32_0] using urel32_0 x by auto 

lemma urel32_power: "urel32 x x'  urel32 y (int y')  urel32 (power_p32 pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
  case (1 x' y' x y)
  note x = 1(2) note y = 1(3)
  show ?case
  proof (cases "y' = 0")
    case True
    hence y: "y = 0" using urel32_eq[OF y urel32_0] by auto
    show ?thesis unfolding y True by (simp add: power_p.simps urel32_1)
  next
    case False
    hence id: "(y = 0) = False" "(y' = 0) = False" using urel32_eq[OF y urel32_0] by auto
    obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
    from divmod_nat_def[of y' 2, unfolded dr']
    have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
    have "urel32 (y AND 1) r'"
      unfolding r'
      using y
      unfolding urel32_def
      using small
      apply (simp add: ppp and_one_eq)
      apply transfer
      apply transfer
      apply (auto simp add: zmod_int take_bit_int_eq_self)
      apply (rule le_less_trans)
       apply (rule zmod_le_nonneg_dividend)
      apply simp_all
      done
    from urel32_eq[OF this urel32_0]     
    have rem: "(y AND 1 = 0) = (r' = 0)" by simp
    have div: "urel32 (shiftr y 1) (int d')" unfolding d' using y unfolding urel32_def using small
      unfolding ppp 
      apply transfer
      apply transfer
      apply (auto simp add: drop_bit_Suc)
      done
    note IH = 1(1)[OF False refl dr'[symmetric] urel32_mult[OF x x] div]
    show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p32.simps[of _ _ y] dr' id if_False rem
      using IH urel32_mult[OF IH x] by (auto simp: Let_def)
  qed
qed
  

lemma urel32_inverse: assumes x: "urel32 x x'" 
  shows "urel32 (inverse_p32 pp x) (inverse_p p x')" 
proof -
  have p: "urel32 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel32_def unfolding ppp
    by (transfer, auto simp: uint_word_ariths)
  show ?thesis
    unfolding inverse_p32_def inverse_p_def urel32_eq[OF x urel32_0] using urel32_0 urel32_power[OF x p]
    by auto
qed

lemma mod_ring_0_32: "mod_ring_rel32 0 0"
  using urel32_0 mod_ring_0 unfolding mod_ring_rel32_def by blast

lemma mod_ring_1_32: "mod_ring_rel32 1 1"
  using urel32_1 mod_ring_1 unfolding mod_ring_rel32_def by blast

lemma mod_ring_uminus32: "(mod_ring_rel32 ===> mod_ring_rel32) (uminus_p32 pp) uminus"
  using urel32_uminus mod_ring_uminus unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_plus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (plus_p32 pp) (+)"
  using urel32_plus mod_ring_plus unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_minus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (minus_p32 pp) (-)"
  using urel32_minus mod_ring_minus unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_mult32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (mult_p32 pp) ((*))"
  using urel32_mult mod_ring_mult unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_eq32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> (=)) (=) (=)" 
  using urel32_eq mod_ring_eq unfolding mod_ring_rel32_def rel_fun_def by blast

lemma urel32_inj: "urel32 x y  urel32 x z  y = z" 
  using urel32_eq[of x y x z] by auto

lemma urel32_inj': "urel32 x z  urel32 y z  x = y" 
  using urel32_eq[of x z y z] by auto

lemma bi_unique_mod_ring_rel32:
  "bi_unique mod_ring_rel32" "left_unique mod_ring_rel32" "right_unique mod_ring_rel32"
  using bi_unique_mod_ring_rel urel32_inj'
  unfolding mod_ring_rel32_def bi_unique_def left_unique_def right_unique_def
  by (auto simp: urel32_def)  

lemma right_total_mod_ring_rel32: "right_total mod_ring_rel32"
  unfolding mod_ring_rel32_def right_total_def
proof 
  fix y :: "'a mod_ring" 
  from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
  obtain z where zy: "mod_ring_rel z y" by auto  
  hence zp: "0  z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
  hence "urel32 (uint32_of_int z) z" unfolding urel32_def using small unfolding ppp 
    by (auto simp: int_of_uint32_inv) 
  with zy show " x z. urel32 x z  mod_ring_rel z y" by blast
qed

lemma Domainp_mod_ring_rel32: "Domainp mod_ring_rel32 = (λx. 0  x  x < pp)"
proof 
  fix x
  show "Domainp mod_ring_rel32 x = (0  x  x < pp)"   
    unfolding Domainp.simps
    unfolding mod_ring_rel32_def
  proof
    let ?i = "int_of_uint32" 
    assume *: "0  x  x < pp"     
    hence "0  ?i x  ?i x < p" using small unfolding ppp
      by (transfer, auto simp: word_less_def)
    hence "?i x  {0 ..< p}" by auto
    with Domainp_mod_ring_rel
    have "Domainp mod_ring_rel (?i x)" by auto
    from this[unfolded Domainp.simps]
    obtain b where b: "mod_ring_rel (?i x) b" by auto
    show "a b. x = a  (z. urel32 a z  mod_ring_rel z b)" 
    proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
      show "urel32 x (?i x)" unfolding urel32_def using small * unfolding ppp
        by (transfer, auto simp: word_less_def)
    qed
  next
    assume "a b. x = a  (z. urel32 a z  mod_ring_rel z b)" 
    then obtain b z where xz: "urel32 x z" and zb: "mod_ring_rel z b" by auto
    hence "Domainp mod_ring_rel z"  by auto
    with Domainp_mod_ring_rel have "0  z" "z < p" by auto
    with xz show "0  x  x < pp" unfolding urel32_def using small unfolding ppp
      by (transfer, auto simp: word_less_def)
  qed
qed

lemma ring_finite_field_ops32: "ring_ops (finite_field_ops32 pp) mod_ring_rel32"
  by (unfold_locales, auto simp:
  finite_field_ops32_def
  bi_unique_mod_ring_rel32
  right_total_mod_ring_rel32
  mod_ring_plus32
  mod_ring_minus32
  mod_ring_uminus32
  mod_ring_mult32
  mod_ring_eq32
  mod_ring_0_32
  mod_ring_1_32
  Domainp_mod_ring_rel32)
end
end

context prime_field
begin
context fixes pp :: "uint32" 
  assumes *: "p = int_of_uint32 pp" "p  65535" 
begin

lemma mod_ring_normalize32: "(mod_ring_rel32 ===> mod_ring_rel32) (λx. if x = 0 then 0 else 1) normalize" 
  using urel32_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_mod32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (λx y. if y = 0 then x else 0) (mod)" 
  using urel32_mod[OF *] mod_ring_mod unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_unit_factor32: "(mod_ring_rel32 ===> mod_ring_rel32) (λx. x) unit_factor" 
  using mod_ring_unit_factor unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_inverse32: "(mod_ring_rel32 ===> mod_ring_rel32) (inverse_p32 pp) inverse"
  using urel32_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_divide32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (divide_p32 pp) (/)"
  using mod_ring_inverse32 mod_ring_mult32[OF *]
  unfolding divide_p32_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
    rel_fun_def by blast

lemma finite_field_ops32: "field_ops (finite_field_ops32 pp) mod_ring_rel32"
  by (unfold_locales, insert ring_finite_field_ops32[OF *], auto simp:
  ring_ops_def
  finite_field_ops32_def
  mod_ring_divide32
  mod_ring_inverse32
  mod_ring_mod32
  mod_ring_normalize32)

end
end

(* now there is 64-bit time *)
context
  fixes p :: uint64
begin
definition plus_p64 :: "uint64  uint64  uint64" where
  "plus_p64 x y  let z = x + y in if z  p then z - p else z"

definition minus_p64 :: "uint64  uint64  uint64" where
  "minus_p64 x y  if y  x then x - y else (x + p) - y"

definition uminus_p64 :: "uint64  uint64" where
  "uminus_p64 x = (if x = 0 then 0 else p - x)"

definition mult_p64 :: "uint64  uint64  uint64" where
  "mult_p64 x y = (x * y mod p)"

lemma int_of_uint64_shift: "int_of_uint64 (shiftr n k) = (int_of_uint64 n) div (2 ^ k)" 
  apply transfer
  apply transfer
  apply (simp add: take_bit_drop_bit min_def)
  apply (simp add: drop_bit_eq_div)
  done

lemma int_of_uint64_0_iff: "int_of_uint64 n = 0  n = 0" 
  by (transfer, rule uint_0_iff)
  
lemma int_of_uint64_0: "int_of_uint64 0 = 0" unfolding int_of_uint64_0_iff by simp

lemma int_of_uint64_ge_0: "int_of_uint64 n  0" 
  by (transfer, auto)

lemma two_64: "2 ^ LENGTH(64) = (18446744073709551616 :: int)" by simp

lemma int_of_uint64_plus: "int_of_uint64 (x + y) = (int_of_uint64 x + int_of_uint64 y) mod 18446744073709551616" 
  by (transfer, unfold uint_word_ariths two_64, rule refl)  

lemma int_of_uint64_minus: "int_of_uint64 (x - y) = (int_of_uint64 x - int_of_uint64 y) mod 18446744073709551616" 
  by (transfer, unfold uint_word_ariths two_64, rule refl)  

lemma int_of_uint64_mult: "int_of_uint64 (x * y) = (int_of_uint64 x * int_of_uint64 y) mod 18446744073709551616" 
  by (transfer, unfold uint_word_ariths two_64, rule refl)  

lemma int_of_uint64_mod: "int_of_uint64 (x mod y) = (int_of_uint64 x mod int_of_uint64 y)" 
  by (transfer, unfold uint_mod two_64, rule refl)  

lemma int_of_uint64_inv: "0  x  x < 18446744073709551616  int_of_uint64 (uint64_of_int x) = x"
  by transfer (simp add: take_bit_int_eq_self)

function power_p64 :: "uint64  uint64  uint64" where
  "power_p64 x n = (if n = 0 then 1 else
    let rec = power_p64 (mult_p64 x x) (shiftr n 1) in
    if n AND 1 = 0 then rec else mult_p64 rec x)"
  by pat_completeness auto

termination 
proof -
  {
    fix n :: uint64
    assume "n  0" 
    with int_of_uint64_ge_0[of n] int_of_uint64_0_iff[of n] have "int_of_uint64 n > 0" by auto
    hence "0 < int_of_uint64 n" "int_of_uint64 n div 2 < int_of_uint64 n" by auto
  } note * = this
  show ?thesis
    by (relation "measure (λ (x,n). nat (int_of_uint64 n))", auto simp: int_of_uint64_shift *) 
qed

text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.›

definition inverse_p64 :: "uint64  uint64" where
  "inverse_p64 x = (if x = 0 then 0 else power_p64 x (p - 2))"

definition divide_p64 :: "uint64  uint64  uint64"  where
  "divide_p64 x y = mult_p64 x (inverse_p64 y)"

definition finite_field_ops64 :: "uint64 arith_ops_record" where
  "finite_field_ops64  Arith_Ops_Record
      0
      1
      plus_p64
      mult_p64
      minus_p64
      uminus_p64
      divide_p64
      inverse_p64
      (λ x y . if y = 0 then x else 0)
      (λ x . if x = 0 then 0 else 1)
      (λ x . x)
      uint64_of_int
      int_of_uint64
      (λ x. 0  x  x < p)"
end 

lemma shiftr_uint64_code [code_unfold]: "drop_bit 1 x = (uint64_shiftr x 1)"
  by (simp add: uint64_shiftr_def)

text ‹For soundness of the 64-bit implementation, we mainly prove that this implementation
  implements the int-based implementation of GF(p).›
context mod_ring_locale
begin

context fixes pp :: "uint64" 
  assumes ppp: "p = int_of_uint64 pp" 
  and small: "p  4294967295" 
begin

lemmas uint64_simps = 
  int_of_uint64_0
  int_of_uint64_plus 
  int_of_uint64_minus
  int_of_uint64_mult
  

definition urel64 :: "uint64  int  bool" where "urel64 x y = (y = int_of_uint64 x  y < p)" 

definition mod_ring_rel64 :: "uint64  'a mod_ring  bool" where
  "mod_ring_rel64 x y = ( z. urel64 x z  mod_ring_rel z y)" 

lemma urel64_0: "urel64 0 0" unfolding urel64_def using p2 by (simp, transfer, simp)

lemma urel64_1: "urel64 1 1" unfolding urel64_def using p2 by (simp, transfer, simp)

lemma le_int_of_uint64: "(x  y) = (int_of_uint64 x  int_of_uint64 y)" 
  by (transfer, simp add: word_le_def)

lemma urel64_plus: assumes "urel64 x y" "urel64 x' y'"
  shows "urel64 (plus_p64 pp x x') (plus_p p y y')"
proof -    
  let ?x = "int_of_uint64 x" 
  let ?x' = "int_of_uint64 x'" 
  let ?p = "int_of_uint64 pp" 
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x'  p" unfolding urel64_def by auto
  have le: "(pp  x + x') = (?p  ?x + ?x')" unfolding le_int_of_uint64
    using rel small by (auto simp: uint64_simps)
  show ?thesis
  proof (cases "?p  ?x + ?x'")
    case True
    hence True: "(?p  ?x + ?x') = True" by simp
    show ?thesis unfolding id 
      using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def 
      unfolding ppp le True if_True
      using True by (auto simp: uint64_simps)
  next
    case False
    hence False: "(?p  ?x + ?x') = False" by simp
    show ?thesis unfolding id 
      using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def 
      unfolding ppp le False if_False
      using False by (auto simp: uint64_simps)
  qed
qed
  
lemma urel64_minus: assumes "urel64 x y" "urel64 x' y'"
  shows "urel64 (minus_p64 pp x x') (minus_p p y y')"
proof -    
  let ?x = "int_of_uint64 x" 
  let ?x' = "int_of_uint64 x'" 
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x'  p" unfolding urel64_def by auto
  have le: "(x'  x) = (?x'  ?x)" unfolding le_int_of_uint64
    using rel small by (auto simp: uint64_simps)
  show ?thesis
  proof (cases "?x'  ?x")
    case True
    hence True: "(?x'  ?x) = True" by simp
    show ?thesis unfolding id 
      using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def 
      unfolding ppp le True if_True
      using True by (auto simp: uint64_simps)
  next
    case False
    hence False: "(?x'  ?x) = False" by simp
    show ?thesis unfolding id 
      using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def 
      unfolding ppp le False if_False
      using False by (auto simp: uint64_simps)
  qed
qed

lemma urel64_uminus: assumes "urel64 x y"
  shows "urel64 (uminus_p64 pp x) (uminus_p p y)"
proof -    
  let ?x = "int_of_uint64 x"  
  from assms int_of_uint64_ge_0 have id: "y = ?x" 
    and rel: "0  ?x" "?x < p" 
      unfolding urel64_def by auto
  have le: "(x = 0) = (?x = 0)" unfolding int_of_uint64_0_iff
    using rel small by (auto simp: uint64_simps)
  show ?thesis
  proof (cases "?x = 0")
    case True
    hence True: "(?x = 0) = True" by simp
    show ?thesis unfolding id 
      using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def 
      unfolding ppp le True if_True
      using True by (auto simp: uint64_simps)
  next
    case False
    hence False: "(?x = 0) = False" by simp
    show ?thesis unfolding id 
      using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def 
      unfolding ppp le False if_False
      using False by (auto simp: uint64_simps)
  qed
qed

lemma urel64_mult: assumes "urel64 x y" "urel64 x' y'"
  shows "urel64 (mult_p64 pp x x') (mult_p p y y')"
proof -    
  let ?x = "int_of_uint64 x" 
  let ?x' = "int_of_uint64 x'" 
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x' < p" unfolding urel64_def by auto
  from rel have "?x * ?x' < p * p" by (metis mult_strict_mono') 
  also have "  4294967296 * 4294967296"
    by (rule mult_mono, insert p2 small, auto)
  finally have le: "?x * ?x' < 18446744073709551616" by simp
  show ?thesis unfolding id
      using small rel unfolding mult_p64_def mult_p_def Let_def urel64_def 
      unfolding ppp 
    by (auto simp: uint64_simps, unfold int_of_uint64_mod int_of_uint64_mult, 
        subst mod_pos_pos_trivial[of _ 18446744073709551616], insert le, auto)
qed

lemma urel64_eq: assumes "urel64 x y" "urel64 x' y'" 
  shows "(x = x') = (y = y')" 
proof -    
  let ?x = "int_of_uint64 x" 
  let ?x' = "int_of_uint64 x'" 
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
    unfolding urel64_def by auto
  show ?thesis unfolding id by (transfer, transfer) rule
qed

lemma urel64_normalize: 
assumes x: "urel64 x y"
shows "urel64 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
 unfolding urel64_eq[OF x urel64_0] using urel64_0 urel64_1 by auto

lemma urel64_mod: 
assumes x: "urel64 x x'" and y: "urel64 y y'" 
shows "urel64 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
  unfolding urel64_eq[OF y urel64_0] using urel64_0 x by auto 

lemma urel64_power: "urel64 x x'  urel64 y (int y')  urel64 (power_p64 pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
  case (1 x' y' x y)
  note x = 1(2) note y = 1(3)
  show ?case
  proof (cases "y' = 0")
    case True
    hence y: "y = 0" using urel64_eq[OF y urel64_0] by auto
    show ?thesis unfolding y True by (simp add: power_p.simps urel64_1)
  next
    case False
    hence id: "(y = 0) = False" "(y' = 0) = False" using urel64_eq[OF y urel64_0] by auto
    obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
    from divmod_nat_def[of y' 2, unfolded dr']
    have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
    have "urel64 (y AND 1) r'"
      unfolding r'
      using y
      unfolding urel64_def
      using small
      apply (simp add: ppp and_one_eq)
      apply transfer apply transfer
      apply (auto simp add: int_eq_iff nat_take_bit_eq nat_mod_distrib zmod_int)
       apply (auto simp add: zmod_int mod_2_eq_odd)
       apply (metis (full_types) even_take_bit_eq le_less_trans odd_iff_mod_2_eq_one take_bit_nonnegative zero_neq_numeral zmod_le_nonneg_dividend)
      apply (auto simp add: less_le)
      apply (simp add: le_less)
      done
    from urel64_eq[OF this urel64_0]     
    have rem: "(y AND 1 = 0) = (r' = 0)" by simp
    have div: "urel64 (shiftr y 1) (int d')" unfolding d' using y unfolding urel64_def using small
      unfolding ppp
      apply transfer
      apply transfer
      apply (auto simp add: drop_bit_Suc)
      done
    note IH = 1(1)[OF False refl dr'[symmetric] urel64_mult[OF x x] div]
    show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p64.simps[of _ _ y] dr' id if_False rem
      using IH urel64_mult[OF IH x] by (auto simp: Let_def)
  qed
qed
  

lemma urel64_inverse: assumes x: "urel64 x x'" 
  shows "urel64 (inverse_p64 pp x) (inverse_p p x')" 
proof -
  have p: "urel64 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel64_def unfolding ppp
    by (transfer, auto simp: uint_word_ariths)
  show ?thesis
    unfolding inverse_p64_def inverse_p_def urel64_eq[OF x urel64_0] using urel64_0 urel64_power[OF x p]
    by auto
qed

lemma mod_ring_0_64: "mod_ring_rel64 0 0"
  using urel64_0 mod_ring_0 unfolding mod_ring_rel64_def by blast

lemma mod_ring_1_64: "mod_ring_rel64 1 1"
  using urel64_1 mod_ring_1 unfolding mod_ring_rel64_def by blast

lemma mod_ring_uminus64: "(mod_ring_rel64 ===> mod_ring_rel64) (uminus_p64 pp) uminus"
  using urel64_uminus mod_ring_uminus unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_plus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (plus_p64 pp) (+)"
  using urel64_plus mod_ring_plus unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_minus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (minus_p64 pp) (-)"
  using urel64_minus mod_ring_minus unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_mult64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (mult_p64 pp) ((*))"
  using urel64_mult mod_ring_mult unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_eq64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> (=)) (=) (=)" 
  using urel64_eq mod_ring_eq unfolding mod_ring_rel64_def rel_fun_def by blast

lemma urel64_inj: "urel64 x y  urel64 x z  y = z" 
  using urel64_eq[of x y x z] by auto

lemma urel64_inj': "urel64 x z  urel64 y z  x = y" 
  using urel64_eq[of x z y z] by auto

lemma bi_unique_mod_ring_rel64:
  "bi_unique mod_ring_rel64" "left_unique mod_ring_rel64" "right_unique mod_ring_rel64"
  using bi_unique_mod_ring_rel urel64_inj'
  unfolding mod_ring_rel64_def bi_unique_def left_unique_def right_unique_def
  by (auto simp: urel64_def)  

lemma right_total_mod_ring_rel64: "right_total mod_ring_rel64"
  unfolding mod_ring_rel64_def right_total_def
proof 
  fix y :: "'a mod_ring" 
  from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
  obtain z where zy: "mod_ring_rel z y" by auto  
  hence zp: "0  z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
  hence "urel64 (uint64_of_int z) z" unfolding urel64_def using small unfolding ppp 
    by (auto simp: int_of_uint64_inv) 
  with zy show " x z. urel64 x z  mod_ring_rel z y" by blast
qed

lemma Domainp_mod_ring_rel64: "Domainp mod_ring_rel64 = (λx. 0  x  x < pp)"
proof 
  fix x
  show "Domainp mod_ring_rel64 x = (0  x  x < pp)"   
    unfolding Domainp.simps
    unfolding mod_ring_rel64_def
  proof
    let ?i = "int_of_uint64" 
    assume *: "0  x  x < pp"     
    hence "0  ?i x  ?i x < p" using small unfolding ppp
      by (transfer, auto simp: word_less_def)
    hence "?i x  {0 ..< p}" by auto
    with Domainp_mod_ring_rel
    have "Domainp mod_ring_rel (?i x)" by auto
    from this[unfolded Domainp.simps]
    obtain b where b: "mod_ring_rel (?i x) b" by auto
    show "a b. x = a  (z. urel64 a z  mod_ring_rel z b)" 
    proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
      show "urel64 x (?i x)" unfolding urel64_def using small * unfolding ppp
        by (transfer, auto simp: word_less_def)
    qed
  next
    assume "a b. x = a  (z. urel64 a z  mod_ring_rel z b)" 
    then obtain b z where xz: "urel64 x z" and zb: "mod_ring_rel z b" by auto
    hence "Domainp mod_ring_rel z"  by auto
    with Domainp_mod_ring_rel have "0  z" "z < p" by auto
    with xz show "0  x  x < pp" unfolding urel64_def using small unfolding ppp
      by (transfer, auto simp: word_less_def)
  qed
qed

lemma ring_finite_field_ops64: "ring_ops (finite_field_ops64 pp) mod_ring_rel64"
  by (unfold_locales, auto simp:
  finite_field_ops64_def
  bi_unique_mod_ring_rel64
  right_total_mod_ring_rel64
  mod_ring_plus64
  mod_ring_minus64
  mod_ring_uminus64
  mod_ring_mult64
  mod_ring_eq64
  mod_ring_0_64
  mod_ring_1_64
  Domainp_mod_ring_rel64)
end
end

context prime_field
begin
context fixes pp :: "uint64" 
  assumes *: "p = int_of_uint64 pp" "p  4294967295" 
begin

lemma mod_ring_normalize64: "(mod_ring_rel64 ===> mod_ring_rel64) (λx. if x = 0 then 0 else 1) normalize" 
  using urel64_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_mod64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (λx y. if y = 0 then x else 0) (mod)" 
  using urel64_mod[OF *] mod_ring_mod unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_unit_factor64: "(mod_ring_rel64 ===> mod_ring_rel64) (λx. x) unit_factor" 
  using mod_ring_unit_factor unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_inverse64: "(mod_ring_rel64 ===> mod_ring_rel64) (inverse_p64 pp) inverse"
  using urel64_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_divide64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (divide_p64 pp) (/)"
  using mod_ring_inverse64 mod_ring_mult64[OF *]
  unfolding divide_p64_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
    rel_fun_def by blast

lemma finite_field_ops64: "field_ops (finite_field_ops64 pp) mod_ring_rel64"
  by (unfold_locales, insert ring_finite_field_ops64[OF *], auto simp:
  ring_ops_def
  finite_field_ops64_def
  mod_ring_divide64
  mod_ring_inverse64
  mod_ring_mod64
  mod_ring_normalize64)
end
end

(* and a final implementation via integer *)
context
  fixes p :: integer
begin
definition plus_p_integer :: "integer  integer  integer" where
  "plus_p_integer x y  let z = x + y in if z  p then z - p else z"

definition minus_p_integer :: "integer  integer  integer" where
  "minus_p_integer x y  if y  x then x - y else (x + p) - y"

definition uminus_p_integer :: "integer  integer" where
  "uminus_p_integer x = (if x = 0 then 0 else p - x)"

definition mult_p_integer :: "integer  integer  integer" where
  "mult_p_integer x y = (x * y mod p)"

lemma int_of_integer_0_iff: "int_of_integer n = 0  n = 0"
  using integer_eqI by auto
  
lemma int_of_integer_0: "int_of_integer 0 = 0" unfolding int_of_integer_0_iff by simp

lemma int_of_integer_plus: "int_of_integer (x + y) = (int_of_integer x + int_of_integer y)" 
  by simp

lemma int_of_integer_minus: "int_of_integer (x - y) = (int_of_integer x - int_of_integer y)"
  by simp

lemma int_of_integer_mult: "int_of_integer (x * y) = (int_of_integer x * int_of_integer y)" 
  by simp  

lemma int_of_integer_mod: "int_of_integer (x mod y) = (int_of_integer x mod int_of_integer y)" 
  by simp  

lemma int_of_integer_inv: "int_of_integer (integer_of_int x) = x" by simp

lemma int_of_integer_shift: "int_of_integer (shiftr n k) = (int_of_integer n) div (2 ^ k)" 
  by transfer (simp add: int_of_integer_pow shiftr_integer_conv_div_pow2)


function power_p_integer :: "integer  integer  integer" where
  "power_p_integer x n = (if n  0 then 1 else
    let rec = power_p_integer (mult_p_integer x x) (shiftr n 1) in
    if n AND 1 = 0 then rec else mult_p_integer rec x)"
  by pat_completeness auto

termination 
proof -
  {
    fix n :: integer
    assume "¬ (n  0)" 
    hence "n > 0" by auto
    hence "int_of_integer n > 0"
      by (simp add: less_integer.rep_eq)
    hence "0 < int_of_integer n" "int_of_integer n div 2 < int_of_integer n" by auto
  } note * = this
  show ?thesis
    by (relation "measure (λ (x,n). nat (int_of_integer n))", auto simp: * int_of_integer_shift) 
qed

text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.›

definition inverse_p_integer :: "integer  integer" where
  "inverse_p_integer x = (if x = 0 then 0 else power_p_integer x (p - 2))"

definition divide_p_integer :: "integer  integer  integer"  where
  "divide_p_integer x y = mult_p_integer x (inverse_p_integer y)"

definition finite_field_ops_integer :: "integer arith_ops_record" where
  "finite_field_ops_integer  Arith_Ops_Record
      0
      1
      plus_p_integer
      mult_p_integer
      minus_p_integer
      uminus_p_integer
      divide_p_integer
      inverse_p_integer
      (λ x y . if y = 0 then x else 0)
      (λ x . if x = 0 then 0 else 1)
      (λ x . x)
      integer_of_int
      int_of_integer
      (λ x. 0  x  x < p)"
end 

lemma shiftr_integer_code [code_unfold]: "drop_bit 1 x = (integer_shiftr x 1)"
  unfolding shiftr_integer_code using integer_of_nat_1 by auto

text ‹For soundness of the integer implementation, we mainly prove that this implementation
  implements the int-based implementation of GF(p).›
context mod_ring_locale
begin

context fixes pp :: "integer" 
  assumes ppp: "p = int_of_integer pp" 
begin

lemmas integer_simps = 
  int_of_integer_0
  int_of_integer_plus 
  int_of_integer_minus
  int_of_integer_mult
  

definition urel_integer :: "integer  int  bool" where "urel_integer x y = (y = int_of_integer x  y  0  y < p)" 

definition mod_ring_rel_integer :: "integer  'a mod_ring  bool" where
  "mod_ring_rel_integer x y = ( z. urel_integer x z  mod_ring_rel z y)" 

lemma urel_integer_0: "urel_integer 0 0" unfolding urel_integer_def using p2 by simp

lemma urel_integer_1: "urel_integer 1 1" unfolding urel_integer_def using p2 by simp

lemma le_int_of_integer: "(x  y) = (int_of_integer x  int_of_integer y)" 
  by (rule less_eq_integer.rep_eq)

lemma urel_integer_plus: assumes "urel_integer x y" "urel_integer x' y'"
  shows "urel_integer (plus_p_integer pp x x') (plus_p p y y')"
proof -    
  let ?x = "int_of_integer x" 
  let ?x' = "int_of_integer x'" 
  let ?p = "int_of_integer pp" 
  from assms have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x'  p" unfolding urel_integer_def by auto
  have le: "(pp  x + x') = (?p  ?x + ?x')" unfolding le_int_of_integer
    using rel by auto
  show ?thesis
  proof (cases "?p  ?x + ?x'")
    case True
    hence True: "(?p  ?x + ?x') = True" by simp
    show ?thesis unfolding id 
      using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def 
      unfolding ppp le True if_True
      using True by auto
  next
    case False
    hence False: "(?p  ?x + ?x') = False" by simp
    show ?thesis unfolding id 
      using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def 
      unfolding ppp le False if_False
      using False by auto
  qed
qed
  
lemma urel_integer_minus: assumes "urel_integer x y" "urel_integer x' y'"
  shows "urel_integer (minus_p_integer pp x x') (minus_p p y y')"
proof -    
  let ?x = "int_of_integer x" 
  let ?x' = "int_of_integer x'" 
  from assms have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x'  p" unfolding urel_integer_def by auto
  have le: "(x'  x) = (?x'  ?x)" unfolding le_int_of_integer
    using rel by auto
  show ?thesis
  proof (cases "?x'  ?x")
    case True
    hence True: "(?x'  ?x) = True" by simp
    show ?thesis unfolding id 
      using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def 
      unfolding ppp le True if_True
      using True by auto
  next
    case False
    hence False: "(?x'  ?x) = False" by simp
    show ?thesis unfolding id 
      using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def 
      unfolding ppp le False if_False
      using False by auto
  qed
qed

lemma urel_integer_uminus: assumes "urel_integer x y"
  shows "urel_integer (uminus_p_integer pp x) (uminus_p p y)"
proof -    
  let ?x = "int_of_integer x"  
  from assms have id: "y = ?x" 
    and rel: "0  ?x" "?x < p" 
      unfolding urel_integer_def by auto
  have le: "(x = 0) = (?x = 0)" unfolding int_of_integer_0_iff
    using rel by auto
  show ?thesis
  proof (cases "?x = 0")
    case True
    hence True: "(?x = 0) = True" by simp
    show ?thesis unfolding id 
      using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def 
      unfolding ppp le True if_True
      using True by auto
  next
    case False
    hence False: "(?x = 0) = False" by simp
    show ?thesis unfolding id 
      using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def 
      unfolding ppp le False if_False
      using False by auto
  qed
qed

lemma pp_pos: "int_of_integer pp > 0" 
  using ppp nontriv[where 'a = 'a]  unfolding p
  by (simp add: less_integer.rep_eq)

lemma urel_integer_mult: assumes "urel_integer x y" "urel_integer x' y'"
  shows "urel_integer (mult_p_integer pp x x') (mult_p p y y')"
proof -    
  let ?x = "int_of_integer x" 
  let ?x' = "int_of_integer x'" 
  from assms  have id: "y = ?x" "y' = ?x'" 
    and rel: "0  ?x" "?x < p" 
      "0  ?x'" "?x' < p" unfolding urel_integer_def by auto
  from rel(1,3) have xx: "0  ?x * ?x'" by simp
  show ?thesis unfolding id
    using rel unfolding mult_p_integer_def mult_p_def Let_def urel_integer_def     
    unfolding ppp mod_nonneg_pos_int[OF xx pp_pos] using xx pp_pos by simp        
qed

lemma urel_integer_eq: assumes "urel_integer x y" "urel_integer x' y'" 
  shows "(x = x') = (y = y')" 
proof -    
  let ?x = "int_of_integer x" 
  let ?x' = "int_of_integer x'" 
  from assms have id: "y = ?x" "y' = ?x'" 
    unfolding urel_integer_def by auto
  show ?thesis unfolding id integer_eq_iff ..
qed

lemma urel_integer_normalize: 
assumes x: "urel_integer x y"
shows "urel_integer (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
 unfolding urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_1 by auto

lemma urel_integer_mod: 
assumes x: "urel_integer x x'" and y: "urel_integer y y'" 
shows "urel_integer (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
  unfolding urel_integer_eq[OF y urel_integer_0] using urel_integer_0 x by auto 

lemma urel_integer_power: "urel_integer x x'  urel_integer y (int y')  urel_integer (power_p_integer pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
  case (1 x' y' x y)
  note x = 1(2) note y = 1(3)
  show ?case
  proof (cases "y'  0")
    case True
    hence y: "y = 0" "y' = 0" using urel_integer_eq[OF y urel_integer_0] by auto
    show ?thesis unfolding y True by (simp add: power_p.simps urel_integer_1)
  next
    case False
    hence id: "(y  0) = False" "(y' = 0) = False" using False y
      by (auto simp add: urel_integer_def not_le) (metis of_int_integer_of of_int_of_nat_eq of_nat_0_less_iff)
    obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
    from divmod_nat_def[of y' 2, unfolded dr']
    have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
    have aux: " y'. int (y' mod 2) = int y' mod 2" by presburger
    have "urel_integer (y AND 1) r'" unfolding r' using y unfolding urel_integer_def 
      unfolding ppp
      apply (auto simp add: and_one_eq)
      apply (simp add: of_nat_mod)
      done
    from urel_integer_eq[OF this urel_integer_0]     
    have rem: "(y AND 1 = 0) = (r' = 0)" by simp
    have div: "urel_integer (shiftr y 1) (int d')" unfolding d' using y unfolding urel_integer_def
      unfolding ppp shiftr_integer_conv_div_pow2 by auto
    from id have "y'  0" by auto
    note IH = 1(1)[OF this refl dr'[symmetric] urel_integer_mult[OF x x] div]
    show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p_integer.simps[of _ _ y] dr' id if_False rem
      using IH urel_integer_mult[OF IH x] by (auto simp: Let_def)
  qed
qed
  

lemma urel_integer_inverse: assumes x: "urel_integer x x'" 
  shows "urel_integer (inverse_p_integer pp x) (inverse_p p x')" 
proof -
  have p: "urel_integer (pp - 2) (int (nat (p - 2)))" using p2 unfolding urel_integer_def unfolding ppp
    by auto
  show ?thesis
    unfolding inverse_p_integer_def inverse_p_def urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_power[OF x p]
    by auto
qed

lemma mod_ring_0__integer: "mod_ring_rel_integer 0 0"
  using urel_integer_0 mod_ring_0 unfolding mod_ring_rel_integer_def by blast

lemma mod_ring_1__integer: "mod_ring_rel_integer 1 1"
  using urel_integer_1 mod_ring_1 unfolding mod_ring_rel_integer_def by blast

lemma mod_ring_uminus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (uminus_p_integer pp) uminus"
  using urel_integer_uminus mod_ring_uminus unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_plus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (plus_p_integer pp) (+)"
  using urel_integer_plus mod_ring_plus unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_minus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (minus_p_integer pp) (-)"
  using urel_integer_minus mod_ring_minus unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_mult_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (mult_p_integer pp) ((*))"
  using urel_integer_mult mod_ring_mult unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_eq_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> (=)) (=) (=)" 
  using urel_integer_eq mod_ring_eq unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma urel_integer_inj: "urel_integer x y  urel_integer x z  y = z" 
  using urel_integer_eq[of x y x z] by auto

lemma urel_integer_inj': "urel_integer x z  urel_integer y z  x = y" 
  using urel_integer_eq[of x z y z] by auto

lemma bi_unique_mod_ring_rel_integer:
  "bi_unique mod_ring_rel_integer" "left_unique mod_ring_rel_integer" "right_unique mod_ring_rel_integer"
  using bi_unique_mod_ring_rel urel_integer_inj'
  unfolding mod_ring_rel_integer_def bi_unique_def left_unique_def right_unique_def
  by (auto simp: urel_integer_def)  

lemma right_total_mod_ring_rel_integer: "right_total mod_ring_rel_integer"
  unfolding mod_ring_rel_integer_def right_total_def
proof 
  fix y :: "'a mod_ring" 
  from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
  obtain z where zy: "mod_ring_rel z y" by auto  
  hence zp: "0  z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
  hence "urel_integer (integer_of_int z) z" unfolding urel_integer_def unfolding ppp 
    by auto 
  with zy show " x z. urel_integer x z  mod_ring_rel z y" by blast
qed

lemma Domainp_mod_ring_rel_integer: "Domainp mod_ring_rel_integer = (λx. 0  x  x < pp)"
proof 
  fix x
  show "Domainp mod_ring_rel_integer x = (0  x  x < pp)"   
    unfolding Domainp.simps
    unfolding mod_ring_rel_integer_def
  proof
    let ?i = "int_of_integer" 
    assume *: "0  x  x < pp"     
    hence "0  ?i x  ?i x < p" unfolding ppp 
      by (simp add: le_int_of_integer less_integer.rep_eq)
    hence "?i x  {0 ..< p}" by auto
    with Domainp_mod_ring_rel
    have "Domainp mod_ring_rel (?i x)" by auto
    from this[unfolded Domainp.simps]
    obtain b where b: "mod_ring_rel (?i x) b" by auto
    show "a b. x = a  (z. urel_integer a z  mod_ring_rel z b)" 
    proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
      show "urel_integer x (?i x)" unfolding urel_integer_def using * unfolding ppp
        by (simp add: le_int_of_integer less_integer.rep_eq)
    qed
  next
    assume "a b. x = a  (z. urel_integer a z  mod_ring_rel z b)" 
    then obtain b z where xz: "urel_integer x z" and zb: "mod_ring_rel z b" by auto
    hence "Domainp mod_ring_rel z"  by auto
    with Domainp_mod_ring_rel have "0  z" "z < p" by auto
    with xz show "0  x  x < pp" unfolding urel_integer_def unfolding ppp
      by (simp add: le_int_of_integer less_integer.rep_eq)
  qed
qed

lemma ring_finite_field_ops_integer: "ring_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
  by (unfold_locales, auto simp:
  finite_field_ops_integer_def
  bi_unique_mod_ring_rel_integer
  right_total_mod_ring_rel_integer
  mod_ring_plus_integer
  mod_ring_minus_integer
  mod_ring_uminus_integer
  mod_ring_mult_integer
  mod_ring_eq_integer
  mod_ring_0__integer
  mod_ring_1__integer
  Domainp_mod_ring_rel_integer)
end
end

context prime_field
begin
context fixes pp :: "integer" 
  assumes *: "p = int_of_integer pp"  
begin

lemma mod_ring_normalize_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (λx. if x = 0 then 0 else 1) normalize" 
  using urel_integer_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_mod_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (λx y. if y = 0 then x else 0) (mod)" 
  using urel_integer_mod[OF *] mod_ring_mod unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_unit_factor_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (λx. x) unit_factor" 
  using mod_ring_unit_factor unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_inverse_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (inverse_p_integer pp) inverse"
  using urel_integer_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_divide_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (divide_p_integer pp) (/)"
  using mod_ring_inverse_integer mod_ring_mult_integer[OF *]
  unfolding divide_p_integer_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
    rel_fun_def by blast

lemma finite_field_ops_integer: "field_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
  by (unfold_locales, insert ring_finite_field_ops_integer[OF *], auto simp:
  ring_ops_def
  finite_field_ops_integer_def
  mod_ring_divide_integer
  mod_ring_inverse_integer
  mod_ring_mod_integer
  mod_ring_normalize_integer)
end
end

context prime_field
begin
 (* four implementations of modular integer arithmetic for finite fields *)
thm 
  finite_field_ops64
  finite_field_ops32
  finite_field_ops_integer
  finite_field_ops_int
end

context mod_ring_locale
begin
 (* four implementations of modular integer arithmetic for finite rings *)
thm 
  ring_finite_field_ops64
  ring_finite_field_ops32
  ring_finite_field_ops_integer
  ring_finite_field_ops_int
end

no_notation shiftr (infixl ">>" 55) (* to avoid conflict with bind *)
end

Theory Matrix_Record_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Matrix Operations in Fields›

text ‹We use our record based description of a field to perform matrix operations.›

theory Matrix_Record_Based
imports 
  Jordan_Normal_Form.Gauss_Jordan_Elimination
  Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
  Arithmetic_Record_Based   
begin


definition mat_rel :: "('a  'b  bool)  'a mat  'b mat  bool" where
  "mat_rel R A B  dim_row A = dim_row B  dim_col A = dim_col B  
     ( i j. i < dim_row B  j < dim_col B  R (A $$ (i,j)) (B $$ (i,j)))"

lemma right_total_mat_rel: "right_total R  right_total (mat_rel R)" 
  unfolding right_total_def
proof
  fix B
  assume " y.  x. R x y"
  from choice[OF this] obtain f where f: " x. R (f x) x" by auto
  show " A. mat_rel R A B"
    by (rule exI[of _ "map_mat f B"], unfold mat_rel_def, auto simp: f)
qed

lemma left_unique_mat_rel: "left_unique R  left_unique (mat_rel R)"
  unfolding left_unique_def mat_rel_def mat_eq_iff by (auto, blast)

lemma right_unique_mat_rel: "right_unique R  right_unique (mat_rel R)"
  unfolding right_unique_def mat_rel_def mat_eq_iff by (auto, blast)

lemma bi_unique_mat_rel: "bi_unique R  bi_unique (mat_rel R)"
  using left_unique_mat_rel[of R] right_unique_mat_rel[of R]
  unfolding bi_unique_def left_unique_def right_unique_def by blast

lemma mat_rel_eq: "((R ===> R ===> (=))) (=) (=)  
  ((mat_rel R ===> mat_rel R ===> (=))) (=) (=)"
  unfolding mat_rel_def rel_fun_def mat_eq_iff by (auto, blast+)

definition vec_rel :: "('a  'b  bool)  'a vec  'b vec  bool" where
  "vec_rel R A B  dim_vec A = dim_vec B  ( i. i < dim_vec B  R (A $ i) (B $ i))"

lemma right_total_vec_rel: "right_total R  right_total (vec_rel R)" 
  unfolding right_total_def
proof
  fix B
  assume " y.  x. R x y"
  from choice[OF this] obtain f where f: " x. R (f x) x" by auto
  show " A. vec_rel R A B"
    by (rule exI[of _ "map_vec f B"], unfold vec_rel_def, auto simp: f)
qed

lemma left_unique_vec_rel: "left_unique R  left_unique (vec_rel R)"
  unfolding left_unique_def vec_rel_def vec_eq_iff by auto

lemma right_unique_vec_rel: "right_unique R  right_unique (vec_rel R)"
  unfolding right_unique_def vec_rel_def vec_eq_iff by auto

lemma bi_unique_vec_rel: "bi_unique R  bi_unique (vec_rel R)"
  using left_unique_vec_rel[of R] right_unique_vec_rel[of R]
  unfolding bi_unique_def left_unique_def right_unique_def by blast

lemma vec_rel_eq: "((R ===> R ===> (=))) (=) (=)  
  ((vec_rel R ===> vec_rel R ===> (=))) (=) (=)"
  unfolding vec_rel_def rel_fun_def vec_eq_iff by (auto, blast+)

lemma multrow_transfer[transfer_rule]: "((R ===> R ===> R) ===> (=) ===> R
  ===> mat_rel R ===> mat_rel R) mat_multrow_gen mat_multrow_gen"
  unfolding mat_rel_def[abs_def] mat_multrow_gen_def[abs_def]
  by (intro rel_funI conjI allI impI eq_matI, auto simp: rel_fun_def) 

(* we need index restrictions, TODO: can this be incorporated into transfer rule? *)
lemma swap_rows_transfer: "mat_rel R A B  i < dim_row B  j < dim_row B  
  mat_rel R (mat_swaprows i j A) (mat_swaprows i j B)"
  unfolding mat_rel_def mat_swaprows_def
  by (intro rel_funI conjI allI impI eq_matI, auto)

lemma pivot_positions_gen_transfer: assumes [transfer_rule]: "(R ===> R ===> (=)) (=) (=)" 
  shows 
  "(R ===> mat_rel R ===> (=)) pivot_positions_gen pivot_positions_gen" 
proof (intro rel_funI, goal_cases)
  case (1 ze ze' A A')
  note trans[transfer_rule] = 1  
  from 1 have dim: "dim_row A = dim_row A'" "dim_col A = dim_col A'" unfolding mat_rel_def by auto
  obtain i j where id: "i = 0" "j = 0" and ij: "i  dim_row A'" "j  dim_col A'" by auto
  have "pivot_positions_main_gen ze A (dim_row A) (dim_col A) i j =
    pivot_positions_main_gen ze' A' (dim_row A') (dim_col A') i j"
    using ij
  proof (induct i j rule: pivot_positions_main_gen.induct[of "dim_row A'" "dim_col A'" A' ze'])
    case (1 i j)    
    note simps[simp] = pivot_positions_main_gen.simps[of _ _ _ _ i j]
    show ?case 
    proof (cases "i < dim_row A'  j < dim_col A'")
      case False
      with dim show ?thesis by auto
    next
      case True
      hence ij: "i < dim_row A'" "j < dim_col A'" and j: "Suc j  dim_col A'" by auto
      note IH = 1(1-2)[OF ij _ _ j]
      from ij True trans have [transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))" 
        unfolding mat_rel_def by auto
      have eq: "(A $$ (i,j) = ze) = (A' $$ (i,j) = ze')" by transfer_prover
      show ?thesis
      proof (cases "A' $$ (i,j) = ze'")
        case True
        from ij have "i  dim_row A'" by auto
        note IH = IH(1)[OF True this]
        thus ?thesis using True ij dim eq by simp
      next
        case False
        from ij have "Suc i  dim_row A'" by auto
        note IH = IH(2)[OF False this]
        thus ?thesis using False ij dim eq by simp
      qed
    qed
  qed
  thus "pivot_positions_gen ze A = pivot_positions_gen ze' A'"
    unfolding pivot_positions_gen_def id .
qed

lemma set_pivot_positions_main_gen: 
  "set (pivot_positions_main_gen ze A nr nc i j)  {0 ..< nr} × {0 ..< nc}"
proof (induct i j rule: pivot_positions_main_gen.induct[of nr nc A ze])
  case (1 i j)
  note [simp] = pivot_positions_main_gen.simps[of _ _ _ _ i j]
  from 1 show ?case
    by (cases "i < nr  j < nc", auto)
qed
  
lemma find_base_vectors_transfer: assumes [transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
  shows "((R ===> R) ===> R ===> R ===> mat_rel R 
  ===> list_all2 (vec_rel R)) find_base_vectors_gen find_base_vectors_gen"
proof (intro rel_funI, goal_cases)
  case (1 um um' ze ze' on on' A A')
  note trans[transfer_rule] = 1 pivot_positions_gen_transfer[OF assms]
  from 1(4) have dim: "dim_row A = dim_row A'" "dim_col A = dim_col A'" unfolding mat_rel_def by auto
  have id: "pivot_positions_gen ze A = pivot_positions_gen ze' A'" by transfer_prover
  obtain xs where xs: "map snd (pivot_positions_gen ze' A') = xs" by auto
  obtain ys where ys: "[j[0..<dim_col A'] . j  set xs] = ys" by auto
  show "list_all2 (vec_rel R) (find_base_vectors_gen um ze on A) 
    (find_base_vectors_gen um' ze' on' A')"
    unfolding find_base_vectors_gen_def Let_def id xs list_all2_conv_all_nth length_map ys dim
  proof (intro conjI[OF refl] allI impI)
    fix i
    assume i: "i < length ys" 
    define y where "y = ys ! i" 
    from i have y: "y < dim_col A'" unfolding y_def ys[symmetric] using nth_mem by fastforce
    let ?map = "map_of (map prod.swap (pivot_positions_gen ze' A'))"
    {
      fix i
      assume i: "i < dim_col A'"
      and neq: "i  y" 
      have "R (case ?map i of None  ze | Some j  um (A $$ (j, y)))
          (case ?map i of None  ze' | Some j  um' (A' $$ (j, y)))"
      proof (cases "?map i")
        case None
        with trans(2) show ?thesis by auto
      next 
        case (Some j)
        from map_of_SomeD[OF this] have "(j,i)  set (pivot_positions_gen ze' A')" by auto
        from subsetD[OF set_pivot_positions_main_gen this[unfolded pivot_positions_gen_def]]
        have j: "j < dim_row A'" by auto
        with trans(4) y have [transfer_rule]: "R (A $$ (j,y)) (A' $$ (j,y))" unfolding mat_rel_def by auto
        show ?thesis unfolding Some by (simp, transfer_prover)
      qed
    } note main = this
    show "vec_rel R (map (non_pivot_base_gen um ze on A (pivot_positions_gen ze' A')) ys ! i)
          (map (non_pivot_base_gen um' ze' on' A' (pivot_positions_gen ze' A')) ys ! i)"
      unfolding y_def[symmetric] nth_map[OF i]
      unfolding non_pivot_base_gen_def Let_def dim vec_rel_def
      by (intro conjI allI impI, force, insert main, auto simp: trans(3))
  qed
qed
  

lemma eliminate_entries_gen_transfer: assumes *[transfer_rule]: "(R ===> R ===> R) ad ad'"
  "(R ===> R ===> R) mul mul'"
  and vs: " j. j < dim_row B'  R (vs j) (vs' j)" 
  and i: "i < dim_row B'"  
  and B: "mat_rel R B B'"
  shows "mat_rel R 
   (eliminate_entries_gen ad mul vs B i j) 
   (eliminate_entries_gen ad' mul' vs' B' i j)"
proof - 
  note BB = B[unfolded mat_rel_def]  
  show ?thesis unfolding mat_rel_def dim_eliminate_entries_gen
  proof (intro conjI impI allI)
    fix i' j'
    assume ij': "i' < dim_row B'" "j' < dim_col B'"
    with BB have ij: "i'< dim_row B" "j' < dim_col B" by auto
    have [transfer_rule]: "R (B $$ (i', j')) (B' $$ (i', j'))" using BB ij' by auto
    have [transfer_rule]: "R (B $$ (i, j')) (B' $$ (i, j'))" using BB ij' i by auto
    have [transfer_rule]: "R (vs i') (vs' i')" using ij' vs[of i'] by auto
    show "R (eliminate_entries_gen ad mul vs B i j $$ (i', j'))
        (eliminate_entries_gen ad' mul' vs' B' i j $$ (i', j'))" 
      unfolding eliminate_entries_gen_def index_mat(1)[OF ij] index_mat(1)[OF ij'] split
      by transfer_prover
  qed (insert BB, auto)
qed

context
  fixes ops :: "'i arith_ops_record" (structure)
begin
private abbreviation (input) zero where "zero  arith_ops_record.zero ops"
private abbreviation (input) one where "one  arith_ops_record.one ops"
private abbreviation (input) plus where "plus  arith_ops_record.plus ops"
private abbreviation (input) times where "times  arith_ops_record.times ops"
private abbreviation (input) minus where "minus  arith_ops_record.minus ops"
private abbreviation (input) uminus where "uminus  arith_ops_record.uminus ops"
private abbreviation (input) divide where "divide  arith_ops_record.divide ops"
private abbreviation (input) inverse where "inverse  arith_ops_record.inverse ops"
private abbreviation (input) modulo where "modulo  arith_ops_record.modulo ops"
private abbreviation (input) normalize where "normalize  arith_ops_record.normalize ops"

definition eliminate_entries_gen_zero :: "('a  'a  'a)  ('a  'a  'a)  'a  (integer  'a)  'a mat  nat  nat  'a mat" where
  "eliminate_entries_gen_zero minu time z v A I J = mat (dim_row A) (dim_col A) (λ (i, j).
     if v (integer_of_nat i)  z  i  I then minu (A $$ (i,j)) (time (v (integer_of_nat i)) (A $$ (I,j))) else A $$ (i,j))" 
  
definition eliminate_entries_i where "eliminate_entries_i  eliminate_entries_gen_zero minus times zero"
definition multrow_i where "multrow_i  mat_multrow_gen times"
  
lemma dim_eliminate_entries_gen_zero[simp]:
  "dim_row (eliminate_entries_gen_zero mm tt z v B i as) = dim_row B"
  "dim_col (eliminate_entries_gen_zero mm tt z v B i as) = dim_col B"
  unfolding eliminate_entries_gen_zero_def by auto

partial_function (tailrec) gauss_jordan_main_i :: "nat  nat  'i mat  nat  nat  'i mat" where
  [code]: "gauss_jordan_main_i nr nc A i j = (
    if i < nr  j < nc then let aij = A $$ (i,j) in if aij = zero then
      (case [ i' . i' <- [Suc i ..< nr],  A $$ (i',j)  zero] 
        of []  gauss_jordan_main_i nr nc A i (Suc j)
         | (i' # _)  gauss_jordan_main_i nr nc (swaprows i i' A) i j)
      else if aij = one then let 
        v = (λ i. A $$ (nat_of_integer i,j)) in
        gauss_jordan_main_i nr nc
        (eliminate_entries_i v A i j) (Suc i) (Suc j)
      else let iaij = inverse aij; A' = multrow_i i iaij A;
        v = (λ i. A' $$ (nat_of_integer i,j))
        in gauss_jordan_main_i nr nc (eliminate_entries_i v A' i j) (Suc i) (Suc j)
    else A)"

definition gauss_jordan_single_i :: "'i mat  'i mat" where
  "gauss_jordan_single_i A  gauss_jordan_main_i (dim_row A) (dim_col A) A 0 0"

definition find_base_vectors_i :: "'i mat  'i vec list" where
  "find_base_vectors_i A  find_base_vectors_gen uminus zero one A"
end

(* **************************************************************************** *)
(* subsection ‹Proofs› *)

context field_ops
begin

lemma right_total_poly_rel[transfer_rule]: "right_total (mat_rel R)"
  using right_total_mat_rel[of R] right_total .

lemma bi_unique_poly_rel[transfer_rule]: "bi_unique (mat_rel R)"
  using bi_unique_mat_rel[of R] bi_unique .

lemma eq_mat_rel[transfer_rule]: "(mat_rel R ===> mat_rel R ===> (=)) (=) (=)"
  by (rule mat_rel_eq[OF eq])

lemma multrow_i[transfer_rule]: "((=) ===> R ===> mat_rel R ===> mat_rel R)
  (multrow_i ops) multrow" 
  using multrow_transfer[of R] times unfolding multrow_i_def rel_fun_def by blast  

lemma eliminate_entries_gen_zero[simp]:
  assumes "mat_rel R A A'" "I < dim_row A'" shows
  "eliminate_entries_gen_zero minus times zero v A I J = eliminate_entries_gen minus times (v o integer_of_nat) A I J"
  unfolding eliminate_entries_gen_def eliminate_entries_gen_zero_def
proof(standard,goal_cases)
  case (1 i j)
  have d1:"DP (A $$ (I, j))" and d2:"DP (A $$ (i, j))" using assms DPR 1
    unfolding mat_rel_def dim_col_mat dim_row_mat
    by (metis Domainp.DomainI)+
  have e1:" x. (0::'a) * x = 0" and e2:" x. x - (0::'a) = x" by auto
  from e1[untransferred,OF d1] e2[untransferred,OF d2] 1 show ?case by auto
qed auto

lemma eliminate_entries_i: assumes  
  vs: " j. j < dim_row B'  R (vs (integer_of_nat j)) (vs' j)" 
  and i: "i < dim_row B'"  
  and B: "mat_rel R B B'"  
  shows "mat_rel R (eliminate_entries_i ops vs B i j) 
    (eliminate_entries vs' B' i j)"
  unfolding eliminate_entries_i_def eliminate_entries_gen_zero[OF B i]
  by (rule eliminate_entries_gen_transfer, insert assms, auto simp: plus times minus)

lemma gauss_jordan_main_i:  
  "nr = dim_row A'  nc = dim_col A'  mat_rel R A A'  i  nr  j  nc 
    mat_rel R (gauss_jordan_main_i ops nr nc A i j) (fst (gauss_jordan_main A' B' i j))"
proof -
  obtain P where P: "P = (A',i,j)" by auto
  let ?Rel = "measures [λ (A' :: 'a mat,i,j). nc - j, λ (A',i,j). if A' $$ (i,j) = 0 then 1 else 0]"
  have wf: "wf ?Rel" by simp
  show "nr = dim_row A'  nc = dim_col A'  mat_rel R A A'  i  nr  j  nc 
    mat_rel R (gauss_jordan_main_i ops nr nc A i j) (fst (gauss_jordan_main A' B' i j))"
    using P
  proof (induct P arbitrary: A' B' A i j rule: wf_induct[OF wf])
    case (1 P A' B' A i j)
    note prems = 1(2-6)
    note P = 1(7)
    note A[transfer_rule] = prems(3)
    note IH = 1(1)[rule_format, OF _ _ _ _ _ _ refl]
    note simps = gauss_jordan_main_code[of A' B' i j, unfolded Let_def, folded prems(1-2)] 
      gauss_jordan_main_i.simps[of ops nr nc A i j] Let_def if_True if_False
    show ?case
    proof (cases "i < nr  j < nc")
      case False
      hence id: "(i < nr  j < nc) = False" by simp
      show ?thesis unfolding simps id by simp transfer_prover
    next
      case True note ij' = this
      hence id: "(i < nr  j < nc) = True" " x y z. (if x = x then y else z) = y" by auto
      from True prems have ij [transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))" 
        unfolding mat_rel_def by auto
      from True prems have i: "i < dim_row A'" "j < dim_col A'" and i': "i < nr" "j < nc" by auto
      {
        fix i
        assume "i < dim_row A'"
        with i True prems have R[transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))" 
          unfolding mat_rel_def by auto
        have "(A $$ (i,j) = zero) = (A' $$ (i,j) = 0)" by transfer_prover
        note this R
      } note eq_gen = this    
      have eq: "(A $$ (i,j) = zero) = (A' $$ (i,j) = 0)"
        "(A $$ (i,j) = one) = (A' $$ (i,j) = 1)"
        by transfer_prover+
      show ?thesis
      proof (cases "A' $$ (i, j) = 0")
        case True
        hence eq: "A $$ (i,j) = zero" using eq by auto
        let ?is = "[ i' . i' <- [Suc i ..< nr],  A $$ (i',j)  zero]"
        let ?is' = "[ i' . i' <- [Suc i ..< nr],  A' $$ (i',j)  0]"
        define xs where "xs = [Suc i..<nr]" 
        have xs: "set xs  {0 ..< dim_row A'}" unfolding xs_def using prems by auto
        hence id': "?is = ?is'" unfolding xs_def[symmetric]
          by (induct xs, insert eq_gen, auto)
        show ?thesis
        proof (cases ?is')
          case Nil
          have "?thesis = (mat_rel R (gauss_jordan_main_i ops nr nc A i (Suc j)) 
            (fst (gauss_jordan_main A' B' i (Suc j))))" 
            unfolding True simps id eq unfolding Nil id'[unfolded Nil] by simp
          also have ""
            by (rule IH, insert i prems P, auto)
          finally show ?thesis .
        next
          case (Cons i' idx')
          from arg_cong[OF this, of set] i 
          have i': "i' < nr" "A' $$ (i', j)  0" by auto
          with ij' prems(1-2) have *: "i' < dim_row A'" "i < dim_row A'" "j < dim_col A'" by auto
          have rel: "((swaprows i i' A', i, j), P)  ?Rel"
            by (simp add: P True * i')
          have "?thesis = (mat_rel R (gauss_jordan_main_i ops nr nc (swaprows i i' A) i j)
            (fst (gauss_jordan_main (swaprows i i' A') (swaprows i i' B') i j)))"
             unfolding True simps id eq Cons id'[unfolded Cons] by simp
          also have "" 
            by (rule IH[OF rel _ _ swap_rows_transfer], insert i i' prems P True, auto)
          finally show ?thesis .
        qed
      next
        case False
        from False eq have neq: "(A $$ (i, j) = zero) = False" "(A' $$ (i, j) = 0) = False" by auto
        {
          fix B B' i
          assume B[transfer_rule]: "mat_rel R B B'" and dim: "dim_col B' = nc" and i: "i < dim_row B'"
          from dim i True have "j < dim_col B'" by simp
          with B i have "R (B $$ (i,j)) (B' $$ (i,j))"
            by (simp add: mat_rel_def)
        } note vec_rel = this        
        from prems have dim: "dim_row A = dim_row A'" unfolding mat_rel_def by auto
        show ?thesis 
        proof (cases "A' $$ (i, j) = 1")
          case True
          from True eq have eq: "(A $$ (i,j) = one) = True" "(A' $$ (i,j) = 1) = True" by auto
          note rel = vec_rel[OF A]
          show ?thesis unfolding simps id neq eq
            by (rule IH[OF _ _ _ eliminate_entries_i], insert rel prems ij i P dim, auto)
        next
          case False
          from False eq have eq: "(A $$ (i,j) = one) = False" "(A' $$ (i,j) = 1) = False" by auto
          show ?thesis unfolding simps id neq eq 
          proof (rule IH, goal_cases)
            case 4
            have A': "mat_rel R (multrow_i ops i (inverse (A $$ (i, j))) A)
              (multrow i (inverse_class.inverse (A' $$ (i, j))) A')" by transfer_prover
            note rel = vec_rel[OF A']
            show ?case 
              by (rule eliminate_entries_i[OF _ _ A'], insert rel prems i dim, auto)
          qed (insert prems i P, auto)
        qed
      qed
    qed
  qed   
qed

lemma gauss_jordan_i[transfer_rule]:  
  "(mat_rel R ===> mat_rel R) (gauss_jordan_single_i ops) gauss_jordan_single"
proof (intro rel_funI)
  fix A A'
  assume A: "mat_rel R A A'"
  show "mat_rel R (gauss_jordan_single_i ops A) (gauss_jordan_single A')"
    unfolding gauss_jordan_single_def gauss_jordan_single_i_def gauss_jordan_def
    by (rule gauss_jordan_main_i[OF _ _ A], insert A, auto simp: mat_rel_def)
qed

lemma find_base_vectors_i[transfer_rule]:  
  "(mat_rel R ===> list_all2 (vec_rel R)) (find_base_vectors_i ops) find_base_vectors"
  unfolding find_base_vectors_i_def[abs_def] 
  using find_base_vectors_transfer[OF eq] uminus zero one 
  unfolding rel_fun_def by blast
  
end

lemma list_of_vec_transfer[transfer_rule]: "(vec_rel A ===> list_all2 A) list_of_vec list_of_vec"
  unfolding rel_fun_def vec_rel_def vec_eq_iff list_all2_conv_all_nth
  by auto

lemma IArray_sub'[simp]: "i < IArray.length a  IArray.sub' (a, integer_of_nat i) = IArray.sub a i" 
  by auto

lift_definition eliminate_entries_i2 ::
  "'a  ('a  'a  'a)  ('a  'a  'a)  (integer  'a)  'a mat_impl  integer  'a mat_impl" is
  "λ z mminus ttimes v (nr, nc, a) i'.
   (nr,nc,let ai' = IArray.sub' (a, i') in (IArray.tabulate (integer_of_nat nr, λ i. let ai = IArray.sub' (a, i) in
     if i = i' then ai else 
     let vi'j = v i 
     in if vi'j = z then ai
        else 
             IArray.tabulate (integer_of_nat nc, λ j. mminus (IArray.sub' (ai, j)) (ttimes vi'j 
               (IArray.sub' (ai', j))))
       )))" 
proof(goal_cases)
  case (1 z mm tt  vec prod nat2)
  thus ?case by(cases prod;cases "snd (snd prod)";auto simp:Let_def)
qed

lemma eliminate_entries_gen_zero [simp]:
  assumes "i<(dim_row A)" "j<(dim_col A)" shows
  "eliminate_entries_gen_zero mminus ttimes z v A I J $$ (i, j) =
   (if v (integer_of_nat i) = z  i = I then A $$ (i,j) else mminus (A $$ (i,j)) (ttimes (v (integer_of_nat i)) (A $$ (I,j))))"
using assms unfolding eliminate_entries_gen_zero_def by auto


lemma eliminate_entries_gen [simp]:
  assumes "i<(dim_row A)" "j<(dim_col A)" shows
  "eliminate_entries_gen mminus ttimes v A I J $$ (i, j) =
   (if i = I then A $$ (i,j) else mminus (A $$ (i,j)) (ttimes (v i) (A $$ (I,j))))"
using assms unfolding eliminate_entries_gen_def by auto

lemma dim_mat_impl [simp]:
  "dim_row (mat_impl x) = dim_row_impl x"
  "dim_col (mat_impl x) = dim_col_impl x"
  by (cases "Rep_mat_impl x";auto simp:mat_impl.rep_eq dim_row_def dim_col_def dim_row_impl.rep_eq dim_col_impl.rep_eq)+

lemma dim_eliminate_entries_i2 [simp]:
  "dim_row_impl (eliminate_entries_i2 z mm tt v m i) = dim_row_impl m"
  "dim_col_impl (eliminate_entries_i2 z mm tt v m i) = dim_col_impl m"
  by (transfer, auto)+

lemma tabulate_nth: "i < n  IArray.tabulate (integer_of_nat n, f) !! i = f (integer_of_nat i)" 
  using of_fun_nth[of i n] by auto

lemma eliminate_entries_i2[code]:"eliminate_entries_gen_zero mm tt z v (mat_impl m) i j
   = (if i < dim_row_impl m 
     then mat_impl (eliminate_entries_i2 z mm tt v m (integer_of_nat i))
     else (Code.abort (STR ''index out of range in eliminate_entries'') 
       (λ _. eliminate_entries_gen_zero mm tt z v (mat_impl m) i j)))"
proof (cases "i < dim_row_impl m")
  case True
  hence id: "(i < dim_row_impl m) = True" by simp
  show ?thesis unfolding id if_True
  proof (standard;goal_cases)
    case (1 i j)
    have dims: "i < dim_row (mat_impl m)" "j < dim_col (mat_impl m)" using 1 by (auto simp:eliminate_entries_i2.rep_eq)
    then show ?case unfolding eliminate_entries_gen_zero[OF dims] using True
    proof(transfer, goal_cases)
      case (1 i m j ia v z mm tt)
      obtain nr nc M where m: "m = (nr,nc,M)" by (cases m) 
      note 1 = 1[unfolded m, simplified]
      have mk: " f. mk_mat nr nc f (i,j) = f (i,j)" 
         " f. mk_mat nr nc f (ia,j) = f (ia,j)" 
        using 1 unfolding mk_mat_def mk_vec_def by auto
      note of_fun = of_fun_nth[OF 1(2)] of_fun_nth[OF 1(3)] tabulate_nth[OF 1(2)] tabulate_nth[OF 1(3)]
      let ?c1 = "v (integer_of_nat i) = z" 
      show ?case
      proof (cases "?c1  i = ia")
        case True
        hence id: "(if ?c1  i = ia then x else y) = x" 
          "(if integer_of_nat i = integer_of_nat ia then x else if ?c1 then x else y) = x" for x y 
          by auto
        show ?thesis unfolding id m o_def Let_def split snd_conv mk of_fun by (auto simp: 1)
      next
        case False
        hence id: "?c1 = False " "(integer_of_nat i = integer_of_nat ia) = False" "(False  i = ia) = False" 
          by (auto simp add: integer_of_nat_eq_of_nat)
        show ?thesis unfolding m o_def Let_def split snd_conv mk of_fun id if_False 
          by (auto simp: 1)
      qed
    qed  
  qed (auto simp:eliminate_entries_i2.rep_eq)
qed auto

end

Theory Missing_Multiset2

theory Missing_Multiset2
  imports "HOL-Library.Multiset" "HOL-Library.Permutation" "HOL-Library.Permutations"
    Containers.Containers_Auxiliary (* only for a lemma *)
begin

subsubsection ‹Missing muiltiset›

lemma id_imp_bij:
  assumes id: "x. f (f x) = x" shows "bij f"
proof (intro bijI injI surjI[of f, OF id])
  fix x y assume "f x = f y"
  then have "f (f x) = f (f y)" by auto
  with id show "x = y" by auto
qed

lemma rel_mset_Zero_iff[simp]:
  shows "rel_mset rel {#} Y  Y = {#}" and "rel_mset rel X {#}  X = {#}"
  using rel_mset_Zero rel_mset_size by (fastforce, fastforce)

definition "is_mset_set X  x ∈# X. count X x = 1"

lemma is_mset_setD[dest]: "is_mset_set X  x ∈# X  count X x = 1"
  unfolding is_mset_set_def by auto

lemma is_mset_setI[intro]:
  assumes "x. x ∈# X  count X x = 1"
  shows "is_mset_set X"
  using assms unfolding is_mset_set_def by auto

lemma is_mset_set[simp]: "is_mset_set (mset_set X)"
  unfolding is_mset_set_def
  by (meson count_mset_set(1) count_mset_set(2) count_mset_set(3) not_in_iff)

lemma is_mset_set_add[simp]:
  "is_mset_set (X + {#x#})  is_mset_set X  x ∉# X" (is "?L  ?R")
proof(intro iffI conjI)
  assume L: ?L
  with count_eq_zero_iff count_single show "is_mset_set X"
    unfolding is_mset_set_def
    by (metis (no_types, hide_lams) add_mset_add_single count_add_mset nat.inject set_mset_add_mset_insert union_single_eq_member)
  show "x ∉# X"
  proof
    assume "x ∈# X"
    then have "count (X + {#x#}) x > 1" by auto
    with L show False by (auto simp: is_mset_set_def)
  qed
next
  assume R: ?R show ?L
  proof
    fix x' assume x': "x' ∈# X + {#x#}"
    show "count (X + {#x#}) x' = 1"
    proof(cases "x' ∈# X")
      case True with R have "count X x' = 1" by auto
        moreover from True R have "count {#x#} x' = 0" by auto
        ultimately show ?thesis by auto
    next
      case False then have "count X x' = 0" by (simp add: not_in_iff)
        with R x' show ?thesis by auto
    qed
  qed
qed


lemma mset_set_id[simp]:
  assumes "is_mset_set X"
  shows "mset_set (set_mset X) = X"
  using assms unfolding is_mset_set_def
  by (metis count_eq_zero_iff count_mset_set(1) count_mset_set(3) finite_set_mset multiset_eqI)

lemma count_image_mset:
  shows "count (image_mset f X) y = (x | x ∈# X  y = f x. count X x)"
proof(induct X)
  case empty show ?case by auto
next
  case (add x X)
    define X' where "X'  X + {#x#}"
    have "(z | z ∈# X'  y = f z. count (X + {#x#}) z) =
          (z | z ∈# X'  y = f z. count X z) + (z | z ∈# X'  y = f z. count {#x#} z)"
      unfolding plus_multiset.rep_eq sum.distrib..
    also have split:
      "{z. z ∈# X'  y = f z} =
       {z. z ∈# X'  y = f z  z  x}  {z. z ∈# X'  y = f z  z = x}" by blast
    then have "(z | z ∈# X'  y = f z. count {#x#} z) =
      (z | z ∈# X'  y = f z  z = x. count {#x#} z)"
      unfolding split by (subst sum.union_disjoint, auto)
    also have "... = (if y = f x then 1 else 0)" using card_eq_Suc_0_ex1 by (auto simp: X'_def)
    also have "(z | z ∈# X'  y = f z. count X z) = (z | z ∈# X  y = f z. count X z)"
    proof(cases "x ∈# X")
      case True then have "z ∈# X'  z ∈# X" for z by (auto simp: X'_def)
      then show ?thesis by auto 
    next
      case False
        have split: "{z. z ∈# X'  y = f z} = {z. z ∈# X  y = f z}  {z. z = x  y = f z}"
          by (auto simp: X'_def)
        also have "sum (count X) ... = (z | z ∈# X  y = f z. count X z) + (z | z = x  y = f z. count X z)"
          by (subst sum.union_disjoint, auto simp: False)
        also with False have "z. z = x  y = f z  count X z = 0" by (meson count_inI)
        with sum.neutral_const have "(z | z = x  y = f z. count X z) = 0" by auto
        finally show ?thesis by auto
    qed
    also have "... = count (image_mset f X) y" using add by auto
    finally show ?case by (simp add: X'_def)  
qed

lemma is_mset_set_image:
  assumes "inj_on f (set_mset X)" and "is_mset_set X"
  shows "is_mset_set (image_mset f X)"
proof (cases X)
  case empty then show ?thesis by auto
next
  case (add x X)
    define X' where "X'  add_mset x X"
    with assms add have inj:"inj_on f (set_mset X')"
          and X': "is_mset_set X'" by auto
  show ?thesis
  proof(unfold add, intro is_mset_setI, fold X'_def)
    fix y assume "y ∈# image_mset f X'"
    then have "y  f ` set_mset X'" by auto 
    with inj have "∃!x'. x' ∈# X'  y = f x'" by (meson imageE inj_onD)
    then obtain x' where x': "{x'. x' ∈# X'  y = f x'} = {x'}" by auto
    then have "count (image_mset f X') y = count X' x'"
      unfolding count_image_mset by auto
    also from X' x' have "... = 1" by auto
    finally show "count (image_mset f X') y = 1".
  qed
qed

(* a variant for "right" *)
lemma ex_mset_zip_right:
  assumes "length xs = length ys" "mset ys' = mset ys"
  shows "xs'. length ys' = length xs'  mset (zip xs' ys') = mset (zip xs ys)"
using assms
proof (induct xs ys arbitrary: ys' rule: list_induct2)
  case Nil
  thus ?case
    by auto
next
  case (Cons x xs y ys ys')
  obtain j where j_len: "j < length ys'" and nth_j: "ys' ! j = y"
    by (metis Cons.prems in_set_conv_nth list.set_intros(1) mset_eq_setD)

  define ysa where "ysa = take j ys' @ drop (Suc j) ys'"
  have "mset ys' = {#y#} + mset ysa"
    unfolding ysa_def using j_len nth_j
    by (metis Cons_nth_drop_Suc union_mset_add_mset_right add_mset_remove_trivial add_diff_cancel_left'
        append_take_drop_id mset.simps(2) mset_append)
  hence ms_y: "mset ysa = mset ys"
    by (simp add: Cons.prems)
  then obtain xsa where
    len_a: "length ysa = length xsa" and ms_a: "mset (zip xsa ysa) = mset (zip xs ys)"
    using Cons.hyps(2) by blast

  define xs' where "xs' = take j xsa @ x # drop j xsa"
  have ys': "ys' = take j ysa @ y # drop j ysa"
    using ms_y j_len nth_j Cons.prems ysa_def
    by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc Cons_nth_drop_Suc length_Cons
      length_drop size_mset)
  have j_len': "j  length ysa"
    using j_len ys' ysa_def
    by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
  have "length ys' = length xs'"
    unfolding xs'_def using Cons.prems len_a ms_y
    by (metis add_Suc_right append_take_drop_id length_Cons length_append mset_eq_length)
  moreover have "mset (zip xs' ys') = mset (zip (x # xs) (y # ys))"
    unfolding ys' xs'_def
    apply (rule HOL.trans[OF mset_zip_take_Cons_drop_twice])
    using j_len' by (auto simp: len_a ms_a)
  ultimately show ?case
    by blast
qed

lemma list_all2_reorder_right_invariance:
  assumes rel: "list_all2 R xs ys" and ms_y: "mset ys' = mset ys"
  shows "xs'. list_all2 R xs' ys'  mset xs' = mset xs"
proof -
  have len: "length xs = length ys"
    using rel list_all2_conv_all_nth by auto
  obtain xs' where
    len': "length xs' = length ys'" and ms_xy: "mset (zip xs' ys') = mset (zip xs ys)"
    using len ms_y by (metis ex_mset_zip_right)
  have "list_all2 R xs' ys'"
    using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: mset_eq_setD)
  moreover have "mset xs' = mset xs"
    using len len' ms_xy map_fst_zip mset_map by metis
  ultimately show ?thesis
    by blast
qed

lemma rel_mset_via_perm: "rel_mset rel (mset xs) (mset ys)  (zs. perm xs zs  list_all2 rel zs ys)"
proof (unfold rel_mset_def, intro iffI, goal_cases)
  case 1
  then obtain zs ws where zs: "mset zs = mset xs" and ws: "mset ws = mset ys" and zsws: "list_all2 rel zs ws" by auto
  note list_all2_reorder_right_invariance[OF zsws ws[symmetric], unfolded zs mset_eq_perm]
  then show ?case using perm_sym by auto
next
  case 2
  from this[folded mset_eq_perm] show ?case by force
qed

lemma rel_mset_free:
  assumes rel: "rel_mset rel X Y" and xs: "mset xs = X"
  shows "ys. mset ys = Y  list_all2 rel xs ys"
proof-
  from rel[unfolded rel_mset_def] obtain xs' ys'
    where xs': "mset xs' = X" and ys': "mset ys' = Y" and xsys': "list_all2 rel xs' ys'" by auto
  from xs' xs have "mset xs = mset xs'" by auto
  from mset_eq_permutation[OF this]
  obtain f where perm: "f permutes {..<length xs'}" and xs': "permute_list f xs' = xs".
  then have [simp]: "length xs' = length xs" by auto
  from permute_list_nth[OF perm, unfolded xs'] have *: "i. i < length xs  xs ! i = xs' ! f i" by auto
  note [simp] = list_all2_lengthD[OF xsys',symmetric]
  note [simp] = atLeast0LessThan[symmetric]
  note bij =  permutes_bij[OF perm]
  define ys where "ys  map (nth ys'  f) [0..<length ys']"
  then have [simp]: "length ys = length ys'" by auto 
  have "mset ys = mset (map (nth ys') (map f [0..<length ys']))"
   unfolding ys_def by auto
  also have "... = image_mset (nth ys') (image_mset f (mset [0..<length ys']))"
    by (simp add: multiset.map_comp)
  also have "(mset [0..<length ys']) = mset_set {0..<length ys'}"
    by (metis mset_sorted_list_of_multiset sorted_list_of_mset_set sorted_list_of_set_range) 
  also have "image_mset f (...) = mset_set (f ` {..<length ys'})"
    using subset_inj_on[OF bij_is_inj[OF bij]] by (subst image_mset_mset_set, auto)
  also have "... = mset [0..<length ys']" using perm by (simp add: permutes_image)
  also have "image_mset (nth ys') ... = mset ys'" by(fold mset_map, unfold map_nth, auto)
  finally have "mset ys = Y" using ys' by auto
  moreover have "list_all2 rel xs ys"
  proof(rule list_all2_all_nthI)
    fix i assume i: "i < length xs"
    with * have "xs ! i = xs' ! f i" by auto
    also from i permutes_in_image[OF perm]
    have "rel (xs' ! f i) (ys' ! f i)" by (intro list_all2_nthD[OF xsys'], auto)
    finally show "rel (xs ! i) (ys ! i)" unfolding ys_def using i by simp
  qed simp
  ultimately show ?thesis by auto
qed

lemma rel_mset_split:
  assumes rel: "rel_mset rel (X1+X2) Y"
  shows "Y1 Y2. Y = Y1 + Y2  rel_mset rel X1 Y1  rel_mset rel X2 Y2"
proof-
  obtain xs1 where xs1: "mset xs1 = X1" using ex_mset by auto
  obtain xs2 where xs2: "mset xs2 = X2" using ex_mset by auto
  from xs1 xs2 have "mset (xs1 @ xs2) = X1 + X2" by auto
  from rel_mset_free[OF rel this] obtain ys
    where ys: "mset ys = Y" "list_all2 rel (xs1 @ xs2) ys" by auto
  then obtain ys1 ys2
    where ys12: "ys = ys1 @ ys2"
      and xs1ys1: "list_all2 rel xs1 ys1"
      and xs2ys2: "list_all2 rel xs2 ys2"
    using list_all2_append1 by blast
  from ys12 ys have "Y = mset ys1 + mset ys2" by auto
  moreover from xs1 xs1ys1 have "rel_mset rel X1 (mset ys1)" unfolding rel_mset_def by auto
  moreover from xs2 xs2ys2 have "rel_mset rel X2 (mset ys2)" unfolding rel_mset_def by auto
  ultimately show ?thesis by (subst exI[of _ "mset ys1"], subst exI[of _ "mset ys2"],auto)
qed

lemma rel_mset_OO:
  assumes AB: "rel_mset R A B" and BC: "rel_mset S B C"
  shows "rel_mset (R OO S) A C"
proof-
  from AB obtain as bs where A_as: "A = mset as" and B_bs: "B = mset bs" and as_bs: "list_all2 R as bs"
    by (auto simp: rel_mset_def)
  from rel_mset_free[OF BC] B_bs obtain cs where C_cs: "C = mset cs" and bs_cs: "list_all2 S bs cs"
    by auto
  from list_all2_trans[OF _ as_bs bs_cs, of "R OO S"] A_as C_cs
  show ?thesis by (auto simp: rel_mset_def)
qed

end

Theory Unique_Factorization

theory Unique_Factorization
  imports
    Polynomial_Interpolation.Ring_Hom_Poly
    Polynomial_Factorization.Polynomial_Divisibility
    "HOL-Library.Permutations" 
    "HOL-Computational_Algebra.Euclidean_Algorithm"
    Containers.Containers_Auxiliary (* only for a lemma *)
    Missing_Multiset2
    "HOL-Algebra.Divisibility"
begin

hide_const(open)
  Divisibility.prime
  Divisibility.irreducible

hide_fact(open)
  Divisibility.irreducible_def
  Divisibility.irreducibleI
  Divisibility.irreducibleD
  Divisibility.irreducibleE

hide_const (open) Rings.coprime

lemma irreducible_uminus [simp]:
  fixes a::"'a::idom"
  shows "irreducible (-a)  irreducible a"
  using irreducible_mult_unit_left[of "-1::'a"] by auto

context comm_monoid_mult begin

  definition coprime :: "'a  'a  bool"
    where coprime_def': "coprime p q  r. r dvd p  r dvd q  r dvd 1"

  lemma coprimeI:
    assumes "r. r dvd p  r dvd q  r dvd 1"
    shows "coprime p q" using assms by (auto simp: coprime_def')

  lemma coprimeE:
    assumes "coprime p q"
        and "(r. r dvd p  r dvd q  r dvd 1)  thesis"
    shows thesis using assms by (auto simp: coprime_def')

  lemma coprime_commute [ac_simps]:
    "coprime p q  coprime q p"
    by (auto simp add: coprime_def')

  lemma not_coprime_iff_common_factor:
    "¬ coprime p q  (r. r dvd p  r dvd q  ¬ r dvd 1)"
    by (auto simp add: coprime_def')

end

lemma (in algebraic_semidom) coprime_iff_coprime [simp, code]:
  "coprime = Rings.coprime"
  by (simp add: fun_eq_iff coprime_def coprime_def')

lemma (in comm_semiring_1) coprime_0 [simp]:
  "coprime p 0  p dvd 1" "coprime 0 p  p dvd 1"
  by (auto intro: coprimeI elim: coprimeE dest: dvd_trans)

(**** until here ****)


(* TODO: move or...? *)
lemma dvd_rewrites: "dvd.dvd ((*)) = (dvd)" by (unfold dvd.dvd_def dvd_def, rule)


subsection ‹Interfacing UFD properties›
hide_const (open) Divisibility.irreducible

context comm_monoid_mult_isom begin
  lemma coprime_hom[simp]: "coprime (hom x) y'  coprime x (Hilbert_Choice.inv hom y')"
  proof-
    show ?thesis by (unfold coprime_def', fold ball_UNIV, subst surj[symmetric], simp)
  qed
  lemma coprime_inv_hom[simp]: "coprime (Hilbert_Choice.inv hom x') y  coprime x' (hom y)"
  proof-
    interpret inv: comm_monoid_mult_isom "Hilbert_Choice.inv hom"..
    show ?thesis by simp
  qed
end

subsubsection ‹Original part›

lemma dvd_dvd_imp_smult:
  fixes p q :: "'a :: idom poly"
  assumes pq: "p dvd q" and qp: "q dvd p" shows "c. p = smult c q"
proof (cases "p = 0")
  case True then show ?thesis by auto
next
  case False
  from qp obtain r where r: "p = q * r" by (elim dvdE, auto)
  with False qp have r0: "r  0" and q0: "q  0" by auto
  with divides_degree[OF pq] divides_degree[OF qp] False
  have "degree p = degree q" by auto
  with r degree_mult_eq[OF q0 r0] have "degree r = 0" by auto
  from degree_0_id[OF this] obtain c where "r = [:c:]" by metis
  from r[unfolded this] show ?thesis by auto
qed

lemma dvd_const:
  assumes pq: "(p::'a::semidom poly) dvd q" and q0: "q  0" and degq: "degree q = 0"
  shows "degree p = 0"
proof-
  from dvdE[OF pq] obtain r where *: "q = p * r".
  with q0 have "p  0" "r  0" by auto
  from degree_mult_eq[OF this] degq * show "degree p = 0" by auto
qed

context Rings.dvd begin
  abbreviation ddvd (infix "ddvd" 40) where "x ddvd y  x dvd y  y dvd x"
  lemma ddvd_sym[sym]: "x ddvd y  y ddvd x" by auto
end

context comm_monoid_mult begin
  lemma ddvd_trans[trans]: "x ddvd y  y ddvd z  x ddvd z" using dvd_trans by auto
  lemma ddvd_transp: "transp (ddvd)" by (intro transpI, fact ddvd_trans)
end

context comm_semiring_1 begin

definition mset_factors where "mset_factors F p 
  F  {#}  (f. f ∈# F  irreducible f)  p = prod_mset F"

lemma mset_factorsI[intro!]:
  assumes "f. f ∈# F  irreducible f" and "F  {#}" and "prod_mset F = p"
  shows "mset_factors F p"
  unfolding mset_factors_def using assms by auto

lemma mset_factorsD:
  assumes "mset_factors F p"
  shows "f ∈# F  irreducible f" and "F  {#}" and "prod_mset F = p"
  using assms[unfolded mset_factors_def] by auto

lemma mset_factorsE[elim]:
  assumes "mset_factors F p"
      and "(f. f ∈# F  irreducible f)  F  {#}  prod_mset F = p  thesis"
  shows thesis
  using assms[unfolded mset_factors_def] by auto

lemma mset_factors_imp_not_is_unit:
  assumes "mset_factors F p"
  shows "¬ p dvd 1"
proof(cases F)
  case empty with assms show ?thesis by auto
next
  case (add f F)
  with assms have "¬ f dvd 1" "p = f * prod_mset F" by (auto intro!: irreducible_not_unit)
  then show ?thesis by auto
qed

definition primitive_poly where "primitive_poly f  d. (i. d dvd coeff f i)  d dvd 1"

end

lemma(in semidom) mset_factors_imp_nonzero:
  assumes "mset_factors F p"
  shows "p  0"
proof
  assume "p = 0"
  moreover from assms have "prod_mset F = p" by auto
  ultimately obtain f where "f ∈# F" "f = 0" by auto
  with assms show False by auto
qed

class ufd = idom +
  assumes mset_factors_exist: "x. x  0  ¬ x dvd 1  F. mset_factors F x"
    and mset_factors_unique: "x F G. mset_factors F x  mset_factors G x  rel_mset (ddvd) F G"

subsubsection ‹Connecting to HOL/Divisibility›

context comm_semiring_1 begin

  abbreviation "mk_monoid  carrier = UNIV - {0}, mult = (*), one = 1"

  lemma carrier_0[simp]: "x  carrier mk_monoid  x  0" by auto

  lemmas mk_monoid_simps = carrier_0 monoid.simps

  abbreviation irred where "irred  Divisibility.irreducible mk_monoid"
  abbreviation factor where "factor  Divisibility.factor mk_monoid"
  abbreviation factors where "factors  Divisibility.factors mk_monoid"
  abbreviation properfactor where "properfactor  Divisibility.properfactor mk_monoid"

  lemma factors: "factors fs y  prod_list fs = y  Ball (set fs) irred"
  proof -
    have "prod_list fs = foldr (*) fs 1" by (induct fs, auto)
    thus ?thesis unfolding factors_def by auto
  qed

  lemma factor: "factor x y  (z. z  0  x * z = y)" unfolding factor_def by auto

  lemma properfactor_nz:
    shows "(y :: 'a)  0  properfactor x y  x dvd y  ¬ y dvd x"
    by (auto simp: properfactor_def factor_def dvd_def)

  lemma mem_Units[simp]: "y  Units mk_monoid  y dvd 1"
    unfolding dvd_def Units_def by (auto simp: ac_simps)

end

context idom begin
  lemma irred_0[simp]: "irred (0::'a)" by (unfold Divisibility.irreducible_def, auto simp: factor properfactor_def)
  lemma factor_idom[simp]: "factor (x::'a) y  (if y = 0 then x = 0 else x dvd y)"
    by (cases "y = 0"; auto intro: exI[of _ 1] elim: dvdE simp: factor)

  lemma associated_connect[simp]: "(∼mk_monoid) = (ddvd)" by (intro ext, unfold associated_def, auto)

  lemma essentially_equal_connect[simp]:
    "essentially_equal mk_monoid fs gs  rel_mset (ddvd) (mset fs) (mset gs)"
    by (auto simp: essentially_equal_def rel_mset_via_perm)

  lemma irred_idom_nz:
    assumes x0: "(x::'a)  0"
    shows "irred x  irreducible x"
    using x0 by (auto simp: irreducible_altdef Divisibility.irreducible_def properfactor_nz)


  lemma dvd_dvd_imp_unit_mult:
    assumes xy: "x dvd y" and yx: "y dvd x"
    shows "z. z dvd 1  y = x * z"
  proof(cases "x = 0")
    case True with xy show ?thesis by (auto intro: exI[of _ 1])
  next
    case x0: False
    from xy obtain z where z: "y = x * z" by (elim dvdE, auto)
    from yx obtain w where w: "x = y * w" by (elim dvdE, auto)
    from z w have "x * (z * w) = x" by (auto simp: ac_simps)
    then have "z * w = 1" using x0 by auto
    with z show ?thesis by (auto intro: exI[of _ z])
  qed

  lemma irred_inner_nz:
    assumes x0: "x  0"
    shows "(b. b dvd x  ¬ x dvd b  b dvd 1)  (a b. x = a * b  a dvd 1  b dvd 1)" (is "?l  ?r")
  proof (intro iffI allI impI)
    assume l: ?l
    fix a b
    assume xab: "x = a * b"
    then have ax: "a dvd x" and bx: "b dvd x" by auto
    { assume a1: "¬ a dvd 1"
      with l ax have xa: "x dvd a" by auto
      from dvd_dvd_imp_unit_mult[OF ax xa] obtain z where z1: "z dvd 1" and xaz: "x = a * z" by auto
      from xab x0 have "a  0" by auto
      with xab xaz have "b = z" by auto
      with z1 have "b dvd 1" by auto
    }
    then show "a dvd 1  b dvd 1" by auto
  next
    assume r: ?r
    fix b assume bx: "b dvd x" and xb: "¬ x dvd b"
    then obtain a where xab: "x = a * b" by (elim dvdE, auto simp: ac_simps)
    with r consider "a dvd 1" | "b dvd 1" by auto
    then show "b dvd 1"
    proof(cases)
      case 2 then show ?thesis by auto
    next
      case 1
      then obtain c where ac1: "a * c = 1" by (elim dvdE, auto)
      from xab have "x * c = b * (a * c)" by (auto simp: ac_simps)
      with ac1 have "x * c = b" by auto
      then have "x dvd b" by auto
      with xb show ?thesis by auto
    qed
  qed

  lemma irred_idom[simp]: "irred x  x = 0  irreducible x"
  by (cases "x = 0"; simp add: irred_idom_nz irred_inner_nz irreducible_def)

  lemma assumes "x  0" and "factors fs x" and "f  set fs" shows "f  0"
    using assms by (auto simp: factors)

  lemma factors_as_mset_factors:
    assumes x0: "x  0" and x1: "x  1"
    shows "factors fs x  mset_factors (mset fs) x" using assms
    by (auto simp: factors prod_mset_prod_list)


end

context ufd begin
  interpretation comm_monoid_cancel: comm_monoid_cancel "mk_monoid::'a monoid"
    apply (unfold_locales)
    apply simp_all
    using mult_left_cancel
    apply (auto simp: ac_simps)
    done
  lemma factors_exist:
    assumes "a  0"
    and "¬ a dvd 1"
    shows "fs. set fs  UNIV - {0}  factors fs a"
  proof-
    from mset_factors_exist[OF assms]
    obtain F where "mset_factors F a" by auto
    also from ex_mset obtain fs where "F = mset fs" by metis
    finally have fs: "mset_factors (mset fs) a".
    then have "factors fs a" using assms by (subst factors_as_mset_factors, auto)
    moreover have "set fs  UNIV - {0}" using fs by (auto elim!: mset_factorsE)
    ultimately show ?thesis by auto
  qed

  lemma factors_unique:
    assumes fs: "factors fs a"
       and gs: "factors gs a"
       and a0: "a  0"
       and a1: "¬ a dvd 1"
    shows "rel_mset (ddvd) (mset fs) (mset gs)"
  proof-
    from a1 have "a  1" by auto
    with a0 fs gs have "mset_factors (mset fs) a" "mset_factors (mset gs) a" by (unfold factors_as_mset_factors)
    from mset_factors_unique[OF this] show ?thesis.
  qed

  lemma factorial_monoid: "factorial_monoid (mk_monoid :: 'a monoid)"
    by (unfold_locales; auto simp add: factors_exist factors_unique)

end

lemma (in idom) factorial_monoid_imp_ufd:
  assumes "factorial_monoid (mk_monoid :: 'a monoid)"
  shows "class.ufd ((*) :: 'a  _) 1 (+) 0 (-) uminus"
proof (unfold_locales)
  interpret factorial_monoid "mk_monoid :: 'a monoid" by (fact assms)
  {
    fix x assume x: "x  0" "¬ x dvd 1"
    note * = factors_exist[simplified, OF this]
    with x show "F. mset_factors F x" by (subst(asm) factors_as_mset_factors, auto)
  }
  fix x F G assume FG: "mset_factors F x" "mset_factors G x"
  with mset_factors_imp_not_is_unit have x1: "¬ x dvd 1" by auto
  from FG(1) have x0: "x  0" by (rule mset_factors_imp_nonzero)
  obtain fs gs where fsgs: "F = mset fs" "G = mset gs" using ex_mset by metis
  note FG = FG[unfolded this]
  then have 0: "0  set fs" "0  set gs" by (auto elim!: mset_factorsE)
  from x1 have "x  1" by auto
  note FG[folded factors_as_mset_factors[OF x0 this]]
  from factors_unique[OF this, simplified, OF x0 x1, folded fsgs] 0
  show "rel_mset (ddvd) F G" by auto
qed




subsection ‹Preservation of Irreducibility›


locale comm_semiring_1_hom = comm_monoid_mult_hom hom + zero_hom hom
  for hom :: "'a :: comm_semiring_1  'b :: comm_semiring_1"

locale irreducibility_hom = comm_semiring_1_hom +
  assumes irreducible_imp_irreducible_hom: "irreducible a  irreducible (hom a)"
begin
  lemma hom_mset_factors:
    assumes F: "mset_factors F p"
    shows "mset_factors (image_mset hom F) (hom p)"
  proof (unfold mset_factors_def, intro conjI allI impI)
    from F show "hom p = prod_mset (image_mset hom F)" "image_mset hom F  {#}" by (auto simp: hom_distribs)
    fix f' assume "f' ∈# image_mset hom F"
    then obtain f where f: "f ∈# F" and f'f: "f' = hom f" by auto
    with F irreducible_imp_irreducible_hom show "irreducible f'" unfolding f'f by auto
  qed
end

locale unit_preserving_hom = comm_semiring_1_hom +
  assumes is_unit_hom_if: "x. hom x dvd 1  x dvd 1"
begin
  lemma is_unit_hom_iff[simp]: "hom x dvd 1  x dvd 1" using is_unit_hom_if hom_dvd by force

  lemma irreducible_hom_imp_irreducible:
    assumes irr: "irreducible (hom a)" shows "irreducible a"
  proof (intro irreducibleI)
    from irr show "a  0" by auto
    from irr show "¬ a dvd 1" by (auto dest: irreducible_not_unit)
    fix b c assume "a = b * c"
    then have "hom a = hom b * hom c" by (simp add: hom_distribs)
    with irr have "hom b dvd 1  hom c dvd 1" by (auto dest: irreducibleD)
    then show "b dvd 1  c dvd 1" by simp
  qed
end

locale factor_preserving_hom = unit_preserving_hom + irreducibility_hom
begin
  lemma irreducible_hom[simp]: "irreducible (hom a)  irreducible a"
    using irreducible_hom_imp_irreducible irreducible_imp_irreducible_hom by metis
end

lemma factor_preserving_hom_comp:
  assumes f: "factor_preserving_hom f" and g: "factor_preserving_hom g"
  shows "factor_preserving_hom (f o g)"
proof-
  interpret f: factor_preserving_hom f by (rule f)
  interpret g: factor_preserving_hom g by (rule g)
  show ?thesis by (unfold_locales, auto simp: hom_distribs)
qed

context comm_semiring_isom begin
  sublocale unit_preserving_hom by (unfold_locales, auto)
  sublocale factor_preserving_hom
  proof (standard)
    fix a :: 'a
    assume "irreducible a"
    note a = this[unfolded irreducible_def]
    show "irreducible (hom a)"
    proof (rule ccontr)
      assume "¬ irreducible (hom a)"
      from this[unfolded Factorial_Ring.irreducible_def,simplified] a
      obtain hb hc where eq: "hom a = hb * hc" and nu: "¬ hb dvd 1" "¬ hc dvd 1" by auto
      from bij obtain b where hb: "hb = hom b" by (elim bij_pointE)
      from bij obtain c where hc: "hc = hom c" by (elim bij_pointE)
      from eq[unfolded hb hc, folded hom_mult] have "a = b * c" by auto
      with nu hb hc have "a = b * c" "¬ b dvd 1" "¬ c dvd 1" by auto
      with a show False by auto
    qed
  qed
end


subsubsection‹Back to divisibility›

lemma(in comm_semiring_1) mset_factors_mult:
  assumes F: "mset_factors F a"
      and G: "mset_factors G b"
  shows "mset_factors (F+G) (a*b)"
proof(intro mset_factorsI)
  fix f assume "f ∈# F + G"
  then consider "f ∈# F" | "f ∈# G" by auto
  then show "irreducible f" by(cases, insert F G, auto)
qed (insert F G, auto)

lemma(in ufd) dvd_imp_subset_factors:
  assumes ab: "a dvd b"
      and F: "mset_factors F a"
      and G: "mset_factors G b"
  shows "G'. G' ⊆# G  rel_mset (ddvd) F G'"
proof-
  from F G have a0: "a  0" and b0: "b  0" by (simp_all add: mset_factors_imp_nonzero)
  from ab obtain c where c: "b = a * c" by (elim dvdE, auto)
  with b0 have c0: "c  0" by auto
  show ?thesis
  proof(cases "c dvd 1")
    case True
    show ?thesis
      proof(cases F)
        case empty with F show ?thesis by auto
      next
        case (add f F')
          with F
          have a: "f * prod_mset F' = a"
           and F': "f. f ∈# F'  irreducible f"
           and irrf: "irreducible f" by auto
          from irrf have f0: "f  0" and f1: "¬f dvd 1" by (auto dest: irreducible_not_unit)
          from a c have "(f * c) * prod_mset F' = b" by (auto simp: ac_simps)
          moreover {
            have "irreducible (f * c)" using True irrf by (subst irreducible_mult_unit_right)
            with F' irrf have "f'. f' ∈# F' + {#f * c#}  irreducible f'" by auto
          }
          ultimately have "mset_factors (F' + {#f * c#}) b" by (intro mset_factorsI, auto)
          from mset_factors_unique[OF this G]
          have F'G: "rel_mset (ddvd) (F' + {#f * c#}) G".
          from True add have FF': "rel_mset (ddvd) F (F' + {#f * c#})"
            by (auto simp add: multiset.rel_refl intro!: rel_mset_Plus)
          have "rel_mset (ddvd) F G"
            apply(rule transpD[OF multiset.rel_transp[OF transpI] FF' F'G])
            using ddvd_trans.
          then show ?thesis by auto
      qed
  next
    case False
      from mset_factors_exist[OF c0 this] obtain H where H: "mset_factors H c" by auto
      from c mset_factors_mult[OF F H] have "mset_factors (F + H) b" by auto
      note mset_factors_unique[OF this G]
      from rel_mset_split[OF this] obtain G1 G2
        where "G = G1 + G2" "rel_mset (ddvd) F G1" "rel_mset (ddvd) H G2" by auto
      then show ?thesis by (intro exI[of _ "G1"], auto)
  qed
qed

lemma(in idom) irreducible_factor_singleton:
  assumes a: "irreducible a"
  shows "mset_factors F a  F = {#a#}"
proof(cases F)
  case empty with mset_factorsD show ?thesis by auto
next
  case (add f F')
  show ?thesis
  proof
    assume F: "mset_factors F a"
    from add mset_factorsD[OF F] have *: "a = f * prod_mset F'" by auto
    then have fa: "f dvd a" by auto
    from * a have f0: "f  0" by auto
    from add have "f ∈# F" by auto
    with F have f: "irreducible f" by auto
    from add have "F' ⊆# F" by auto
    then have unitemp: "prod_mset F' dvd 1  F' = {#}"
    proof(induct F')
      case empty then show ?case by auto
    next
      case (add f F')
        from add have "f ∈# F" by (simp add: mset_subset_eq_insertD)
        with F irreducible_not_unit have "¬ f dvd 1" by auto
        then have "¬ (prod_mset F' * f) dvd 1" by simp
        with add show ?case by auto
    qed
    show "F = {#a#}"
    proof(cases "a dvd f")
      case True
        then obtain r where "f = a * r" by (elim dvdE, auto)
        with * have "f = (r * prod_mset F') * f" by (auto simp: ac_simps)
        with f0 have "r * prod_mset F' = 1" by auto
        then have "prod_mset F' dvd 1" by (metis dvd_triv_right)
        with unitemp * add show ?thesis by auto
    next
      case False with fa a f show ?thesis by (auto simp: irreducible_altdef)
    qed
  qed (insert a, auto)
qed


lemma(in ufd) irreducible_dvd_imp_factor:
  assumes ab: "a dvd b"
      and a: "irreducible a"
      and G: "mset_factors G b"
  shows "g ∈# G. a ddvd g"
proof-
  from a have "mset_factors {#a#} a" by auto
  from dvd_imp_subset_factors[OF ab this G]
  obtain G' where G'G: "G' ⊆# G" and rel: "rel_mset (ddvd) {#a#} G'" by auto
  with rel_mset_size size_1_singleton_mset size_single
  obtain g where gG': "G' = {#g#}" by fastforce
  from rel[unfolded this rel_mset_def]
  have "a ddvd g" by auto
  with gG' G'G show ?thesis by auto
qed

lemma(in idom) prod_mset_remove_units:
  "prod_mset F ddvd prod_mset {# f ∈# F. ¬f dvd 1 #}"
proof(induct F)
  case (add f F) then show ?case by (cases "f = 0", auto)
qed auto

lemma(in comm_semiring_1) mset_factors_imp_dvd:
  assumes "mset_factors F x" and "f ∈# F" shows "f dvd x"
  using assms by (simp add: dvd_prod_mset mset_factors_def)

lemma(in ufd) prime_elem_iff_irreducible[iff]:
  "prime_elem x  irreducible x"
proof (intro iffI, fact prime_elem_imp_irreducible, rule prime_elemI)
  assume r: "irreducible x"
  then show x0: "x  0" and x1: "¬ x dvd 1" by (auto dest: irreducible_not_unit)
  from irreducible_factor_singleton[OF r]
  have *: "mset_factors {#x#} x" by auto
  fix a b
  assume "x dvd a * b"
  then obtain c where abxc: "a * b = x * c" by (elim dvdE, auto)
  show "x dvd a  x dvd b"
  proof(cases "c = 0  a = 0  b = 0")
    case True with abxc show ?thesis by auto
  next
    case False
    then have a0: "a  0" and b0: "b  0" and c0: "c  0" by auto
    from x0 c0 have xc0: "x * c  0" by auto
    from x1 have xc1: "¬ x * c dvd 1" by auto
    show ?thesis
    proof (cases "a dvd 1  b dvd 1")
      case False
      then have a1: "¬ a dvd 1" and b1: "¬ b dvd 1" by auto
      from mset_factors_exist[OF a0 a1]
      obtain F where Fa: "mset_factors F a" by auto
      then have F0: "F  {#}" by auto
      from mset_factors_exist[OF b0 b1]
      obtain G where Gb: "mset_factors G b" by auto
      then have G0: "G  {#}" by auto
      from mset_factors_mult[OF Fa Gb]
      have FGxc: "mset_factors (F + G) (x * c)" by (simp add: abxc)
      show ?thesis
      proof (cases "c dvd 1")
        case True
        from r irreducible_mult_unit_right[OF this] have "irreducible (x*c)" by simp
        note irreducible_factor_singleton[OF this] FGxc
        with F0 G0 have False by (cases F; cases G; auto)
        then show ?thesis by auto
      next
        case False
        from mset_factors_exist[OF c0 this] obtain H where "mset_factors H c" by auto
        with * have xHxc: "mset_factors (add_mset x H) (x * c)" by force
        note rel = mset_factors_unique[OF this FGxc]
        obtain hs where "mset hs = H" using ex_mset by auto
        then have "mset (x#hs) = add_mset x H" by auto
        from rel_mset_free[OF rel this]
        obtain jjs where jjsGH: "mset jjs = F + G" and rel: "list_all2 (ddvd) (x # hs) jjs" by auto
        then obtain j js where jjs: "jjs = j # js" by (cases jjs, auto)
        with rel have xj: "x ddvd j" by auto
        from jjs jjsGH have j: "j  set_mset (F + G)" by (intro union_single_eq_member, auto)
        from j consider "j ∈# F" | "j ∈# G" by auto
        then show ?thesis
        proof(cases)
          case 1
          with Fa have "j dvd a" by (auto intro: mset_factors_imp_dvd)
          with xj dvd_trans have "x dvd a" by auto
          then show ?thesis by auto
        next
          case 2
          with Gb have "j dvd b" by (auto intro: mset_factors_imp_dvd)
          with xj dvd_trans have "x dvd b" by auto
          then show ?thesis by auto
        qed
      qed
    next
      case True
      then consider "a dvd 1" | "b dvd 1" by auto
      then show ?thesis
      proof(cases)
        case 1
        then obtain d where ad: "a * d = 1" by (elim dvdE, auto)
        from abxc have "x * (c * d) = a * b * d" by (auto simp: ac_simps)
        also have "... = a * d * b" by (auto simp: ac_simps)
        finally have "x dvd b" by (intro dvdI, auto simp: ad)
        then show ?thesis by auto
      next
        case 2
        then obtain d where bd: "b * d = 1" by (elim dvdE, auto)
        from abxc have "x * (c * d) = a * b * d" by (auto simp: ac_simps)
        also have "... = (b * d) * a" by (auto simp: ac_simps)
        finally have "x dvd a" by (intro dvdI, auto simp:bd)
        then show ?thesis by auto
      qed
    qed
  qed
qed

subsection‹Results for GCDs etc.›

lemma prod_list_remove1: "(x :: 'b :: comm_monoid_mult)  set xs  prod_list (remove1 x xs) * x = prod_list xs"
  by (induct xs, auto simp: ac_simps)

(* Isabelle 2015-style and generalized gcd-class without normalization and factors *)
class comm_monoid_gcd = gcd + comm_semiring_1 +
  assumes gcd_dvd1[iff]: "gcd a b dvd a"
      and gcd_dvd2[iff]: "gcd a b dvd b"
      and gcd_greatest: "c dvd a  c dvd b  c dvd gcd a b"
begin

  lemma gcd_0_0[simp]: "gcd 0 0 = 0"
    using gcd_greatest[OF dvd_0_right dvd_0_right, of 0] by auto

  lemma gcd_zero_iff[simp]: "gcd a b = 0  a = 0  b = 0"
  proof
    assume "gcd a b = 0"
    from gcd_dvd1[of a b, unfolded this] gcd_dvd2[of a b, unfolded this]
    show "a = 0  b = 0" by auto
  qed auto

  lemma gcd_zero_iff'[simp]: "0 = gcd a b  a = 0  b = 0"
    using gcd_zero_iff by metis

  lemma dvd_gcd_0_iff[simp]:
    shows "x dvd gcd 0 a  x dvd a" (is ?g1)
      and "x dvd gcd a 0  x dvd a" (is ?g2)
  proof-
    have "a dvd gcd a 0" "a dvd gcd 0 a" by (auto intro: gcd_greatest)
    with dvd_refl show ?g1 ?g2 by (auto dest: dvd_trans)
  qed

  lemma gcd_dvd_1[simp]: "gcd a b dvd 1  coprime a b"
    using dvd_trans[OF gcd_greatest[of _ a b], of _ 1]
    by (cases "a = 0  b = 0") (auto intro!: coprimeI elim: coprimeE)

  lemma dvd_imp_gcd_dvd_gcd: "b dvd c  gcd a b dvd gcd a c"
    by (meson gcd_dvd1 gcd_dvd2 gcd_greatest dvd_trans)

  definition listgcd :: "'a list  'a" where
    "listgcd xs = foldr gcd xs 0"

  lemma listgcd_simps[simp]: "listgcd [] = 0" "listgcd (x # xs) = gcd x (listgcd xs)"
    by (auto simp: listgcd_def)

  lemma listgcd: "x  set xs  listgcd xs dvd x" 
  proof (induct xs)
    case (Cons y ys)
    show ?case
    proof (cases "x = y")
      case False
      with Cons have dvd: "listgcd ys dvd x" by auto
      thus ?thesis unfolding listgcd_simps using dvd_trans by blast
    next
      case True
      thus ?thesis unfolding listgcd_simps using dvd_trans by blast
    qed
  qed simp

  lemma listgcd_greatest: "( x. x  set xs  y dvd x)  y dvd listgcd xs"
    by (induct xs arbitrary:y, auto intro: gcd_greatest)

end


context Rings.dvd begin

  definition "is_gcd x a b  x dvd a  x dvd b  (y. y dvd a  y dvd b  y dvd x)"

  definition "some_gcd a b  SOME x. is_gcd x a b"

  lemma is_gcdI[intro!]:
    assumes "x dvd a" "x dvd b" "y. y dvd a  y dvd b  y dvd x"
    shows "is_gcd x a b" by (insert assms, auto simp: is_gcd_def)

  lemma is_gcdE[elim!]:
    assumes "is_gcd x a b"
        and "x dvd a  x dvd b  (y. y dvd a  y dvd b  y dvd x)  thesis"
    shows thesis by (insert assms, auto simp: is_gcd_def)

  lemma is_gcd_some_gcdI:
    assumes "x. is_gcd x a b" shows "is_gcd (some_gcd a b) a b"
    by (unfold some_gcd_def, rule someI_ex[OF assms])

end

context comm_semiring_1 begin

  lemma some_gcd_0[intro!]: "is_gcd (some_gcd a 0) a 0" "is_gcd (some_gcd 0 b) 0 b"
    by (auto intro!: is_gcd_some_gcdI intro: exI[of _ a] exI[of _ b])

  lemma some_gcd_0_dvd[intro!]:
    "some_gcd a 0 dvd a" "some_gcd 0 b dvd b" using some_gcd_0 by auto

  lemma dvd_some_gcd_0[intro!]:
    "a dvd some_gcd a 0" "b dvd some_gcd 0 b" using some_gcd_0[of a] some_gcd_0[of b] by auto

end

context idom begin

  lemma is_gcd_connect:
    assumes "a  0" "b  0" shows "isgcd mk_monoid x a b  is_gcd x a b"
    using assms by (force simp: isgcd_def)

  lemma some_gcd_connect:
    assumes "a  0" and "b  0" shows "somegcd mk_monoid a b = some_gcd a b"
    using assms by (auto intro!: arg_cong[of _ _ Eps] simp: is_gcd_connect some_gcd_def somegcd_def)
end

context comm_monoid_gcd
begin
  lemma is_gcd_gcd: "is_gcd (gcd a b) a b" using gcd_greatest by auto
  lemma is_gcd_some_gcd: "is_gcd (some_gcd a b) a b" by (insert is_gcd_gcd, auto intro!: is_gcd_some_gcdI)
  lemma gcd_dvd_some_gcd: "gcd a b dvd some_gcd a b" using is_gcd_some_gcd by auto
  lemma some_gcd_dvd_gcd: "some_gcd a b dvd gcd a b" using is_gcd_some_gcd by (auto intro: gcd_greatest)
  lemma some_gcd_ddvd_gcd: "some_gcd a b ddvd gcd a b" by (auto intro: gcd_dvd_some_gcd some_gcd_dvd_gcd)
  lemma some_gcd_dvd: "some_gcd a b dvd d  gcd a b dvd d" "d dvd some_gcd a b  d dvd gcd a b"
    using some_gcd_ddvd_gcd[of a b] by (auto dest:dvd_trans)

end

class idom_gcd = comm_monoid_gcd + idom
begin

  interpretation raw: comm_monoid_cancel "mk_monoid :: 'a monoid"
    by (unfold_locales, auto intro: mult_commute mult_assoc)

  interpretation raw: gcd_condition_monoid "mk_monoid :: 'a monoid"
    by (unfold_locales, auto simp: is_gcd_connect intro!: exI[of _ "gcd _ _"] dest: gcd_greatest)

  lemma gcd_mult_ddvd:
    "d * gcd a b ddvd gcd (d * a) (d * b)"
  proof (cases "d = 0")
    case True then show ?thesis by auto
  next
    case d0: False
    show ?thesis
    proof (cases "a = 0  b = 0")
      case False
      note some_gcd_ddvd_gcd[of a b]
      with d0 have "d * gcd a b ddvd d * some_gcd a b" by auto
      also have "d * some_gcd a b ddvd some_gcd (d * a) (d * b)"
        using False d0 raw.gcd_mult by (simp add: some_gcd_connect)
      also note some_gcd_ddvd_gcd
      finally show ?thesis.
    next
      case True
      with d0 show ?thesis
        apply (elim disjE)
         apply (rule ddvd_trans[of _ "d * b"]; force)
         apply (rule ddvd_trans[of _ "d * a"]; force)
        done
    qed
  qed

  lemma gcd_greatest_mult: assumes cad: "c dvd a * d" and cbd: "c dvd b * d"
    shows "c dvd gcd a b * d"
  proof-
    from gcd_greatest[OF assms] have c: "c dvd gcd (d * a) (d * b)" by (auto simp: ac_simps)
    note gcd_mult_ddvd[of d a b]
    then have "gcd (d * a) (d * b) dvd gcd a b * d" by (auto simp: ac_simps)
    from dvd_trans[OF c this] show ?thesis .
  qed

  lemma listgcd_greatest_mult: "( x :: 'a. x  set xs  y dvd x * z)  y dvd listgcd xs * z"
  proof (induct xs)
    case (Cons x xs)
    from Cons have "y dvd x * z" "y dvd listgcd xs * z" by auto
    thus ?case unfolding listgcd_simps by (rule gcd_greatest_mult)
  qed (simp)

  lemma dvd_factor_mult_gcd:
    assumes dvd: "k dvd p * q" "k dvd p * r"
      and q0: "q  0" and r0: "r  0"
    shows "k dvd p * gcd q r" 
  proof -
    from dvd gcd_greatest[of k "p * q" "p * r"]
    have "k dvd gcd (p * q) (p * r)" by simp
    also from gcd_mult_ddvd[of p q r]
    have "... dvd (p * gcd q r)" by auto
    finally show ?thesis .
  qed

  lemma coprime_mult_cross_dvd:
    assumes coprime: "coprime p q" and eq: "p' * p = q' * q"
    shows "p dvd q'" (is ?g1) and "q dvd p'" (is ?g2)
  proof (atomize(full), cases "p = 0  q = 0")
    case True
    then show "?g1  ?g2"
    proof
      assume p0: "p = 0" with coprime have "q dvd 1" by auto
      with eq p0 show ?thesis by auto
    next
      assume q0: "q = 0" with coprime have "p dvd 1" by auto
      with eq q0 show ?thesis by auto
    qed
  next
    case False
    {
      fix p q r p' q' :: 'a
      assume cop: "coprime p q" and eq: "p' * p = q' * q" and p: "p  0" and q: "q  0"
         and r: "r dvd p" "r dvd q"
      let ?gcd = "gcd q p"
      from eq have "p' * p dvd q' * q" by auto
      hence d1: "p dvd q' * q" by (rule dvd_mult_right)
      have d2: "p dvd q' * p" by auto
      from dvd_factor_mult_gcd[OF d1 d2 q p] have 1: "p dvd q' * ?gcd" .
      from q p have 2: "?gcd dvd q" by auto
      from q p have 3: "?gcd dvd p" by auto
      from cop[unfolded coprime_def', rule_format, OF 3 2] have "?gcd dvd 1" .
      from 1 dvd_mult_unit_iff[OF this] have "p dvd q'" by auto
    } note main = this
    from main[OF coprime eq,of 1] False coprime coprime_commute main[OF _ eq[symmetric], of 1]
    show "?g1  ?g2" by auto
  qed

end

subclass (in ring_gcd) idom_gcd by (unfold_locales, auto)

lemma coprime_rewrites: "comm_monoid_mult.coprime ((*)) 1 = coprime"
  apply (intro ext)
  apply (subst comm_monoid_mult.coprime_def')
  apply (unfold_locales)
  apply (unfold dvd_rewrites)
  apply (fold coprime_def') ..

(* TODO: incorporate into the default class hierarchy *)
locale gcd_condition =
  fixes ty :: "'a :: idom itself"
  assumes gcd_exists: "a b :: 'a. x. is_gcd x a b"
begin
  sublocale idom_gcd "(*)" "1 :: 'a" "(+)" 0 "(-)" uminus some_gcd 
    rewrites "dvd.dvd ((*)) = (dvd)"
        and "comm_monoid_mult.coprime ((*) ) 1 = Unique_Factorization.coprime"
  proof-
    have "is_gcd (some_gcd a b) a b" for a b :: 'a by (intro is_gcd_some_gcdI gcd_exists)
    from this[unfolded is_gcd_def]
    show "class.idom_gcd (*) (1 :: 'a) (+) 0 (-) uminus some_gcd" by (unfold_locales, auto simp: dvd_rewrites)
  qed (simp_all add: dvd_rewrites coprime_rewrites)
end

instance semiring_gcd  comm_monoid_gcd by (intro_classes, auto)

lemma listgcd_connect: "listgcd = gcd_list"
proof (intro ext)
  fix xs :: "'a list"
  show "listgcd xs = gcd_list xs" by(induct xs, auto)
qed

interpretation some_gcd: gcd_condition "TYPE('a::ufd)"
proof(unfold_locales, intro exI)
  interpret factorial_monoid "mk_monoid :: 'a monoid" by (fact factorial_monoid)
  note d = dvd.dvd_def some_gcd_def carrier_0
  fix a b :: 'a
  show "is_gcd (some_gcd a b) a b"
  proof (cases "a = 0  b = 0")
    case True
    thus ?thesis using some_gcd_0 by auto
  next
    case False
    with gcdof_exists[of a b]
    show ?thesis by (auto intro!: is_gcd_some_gcdI simp add: is_gcd_connect some_gcd_connect)
  qed
qed

lemma some_gcd_listgcd_dvd_listgcd: "some_gcd.listgcd xs dvd listgcd xs"
  by (induct xs, auto simp:some_gcd_dvd intro:dvd_imp_gcd_dvd_gcd)

lemma listgcd_dvd_some_gcd_listgcd: "listgcd xs dvd some_gcd.listgcd xs"
  by (induct xs, auto simp:some_gcd_dvd intro:dvd_imp_gcd_dvd_gcd)

context factorial_ring_gcd begin

text ‹Do not declare the following as subclass, to avoid conflict in
  field ⊆ gcd_condition› vs. factorial_ring_gcd ⊆ gcd_condition›.
›
sublocale as_ufd: ufd
proof(unfold_locales, goal_cases)
  case (1 x)
  from prime_factorization_exists[OF x  0]
  obtain F where f: "f. f ∈# F  prime_elem f" 
             and Fx: "normalize (prod_mset F) = normalize x" by auto
  from associatedE2[OF Fx] obtain u where u: "is_unit u" "x = u * prod_mset F"
    by blast
  from ¬ is_unit x Fx have "F  {#}" by auto
  then obtain g G where F: "F = add_mset g G" by (cases F, auto)
  then have "g ∈# F" by auto
  with f[OF this]prime_elem_iff_irreducible
    irreducible_mult_unit_left[OF unit_factor_is_unit[OF x  0]]
  have g: "irreducible (u * g)" using u(1)
    by (subst irreducible_mult_unit_left) simp_all
  show ?case
  proof (intro exI conjI mset_factorsI)
    show "prod_mset (add_mset (u * g) G) = x"
      using x  0 by (simp add: F ac_simps u)
    fix f assume "f ∈# add_mset (u * g) G"
    with f[unfolded F] g prime_elem_iff_irreducible
    show "irreducible f" by auto
  qed auto
next
  case (2 x F G)
  note transpD[OF multiset.rel_transp[OF ddvd_transp],trans]
  obtain fs where F: "F = mset fs" by (metis ex_mset)
  have "list_all2 (ddvd) fs (map normalize fs)" by (intro list_all2_all_nthI, auto)
  then have FH: "rel_mset (ddvd) F (image_mset normalize F)" by (unfold rel_mset_def F, force)
  also
  have FG: "image_mset normalize F = image_mset normalize G"
  proof (intro prime_factorization_unique'')
    from 2 have xF: "x = prod_mset F" and xG: "x = prod_mset G" by auto
    from xF have "normalize x = normalize (prod_mset (image_mset normalize F))"
      by (simp add: normalize_prod_mset_normalize)
    with xG have nFG: " = normalize (prod_mset (image_mset normalize G))"
      by (simp_all add: normalize_prod_mset_normalize)
    then show "normalize (i∈#image_mset normalize F. i) =
               normalize (i∈#image_mset normalize G. i)" by auto
  next
    from 2 prime_elem_iff_irreducible have "f ∈# F  prime_elem f" "g ∈# G  prime_elem g" for f g
     by (auto intro: prime_elemI)
    then show " Multiset.Ball (image_mset normalize F) prime"
      "Multiset.Ball (image_mset normalize G) prime" by auto
  qed
  also
    obtain gs where G: "G = mset gs" by (metis ex_mset)
    have "list_all2 ((ddvd)¯¯) gs (map normalize gs)" by (intro list_all2_all_nthI, auto)
    then have "rel_mset (ddvd) (image_mset normalize G) G"
      by (subst multiset.rel_flip[symmetric], unfold rel_mset_def G, force)
  finally show ?case.
qed

end

instance int :: ufd by (intro class.ufd.of_class.intro as_ufd.ufd_axioms)
instance int :: idom_gcd by (intro_classes, auto)

instance field  ufd by (intro_classes, auto simp: dvd_field_iff)

end

Theory Unique_Factorization_Poly

(*  
    Author:      René Thiemann 
                 Akihisa Yamada
    License:     BSD
*)
section ‹Unique Factorization Domain for Polynomials›

text ‹In this theory we prove that the polynomials over a unique factorization domain (UFD) form a UFD.›

theory Unique_Factorization_Poly
imports
  Unique_Factorization
  Polynomial_Factorization.Missing_Polynomial_Factorial 
  Subresultants.More_Homomorphisms 
  "HOL-Computational_Algebra.Field_as_Ring"
begin

hide_const (open) module.smult
hide_const (open) Divisibility.irreducible

instantiation fract :: (idom) "{normalization_euclidean_semiring, euclidean_ring}"
begin

definition [simp]: "normalize_fract  (normalize_field :: 'a fract  _)"
definition [simp]: "unit_factor_fract = (unit_factor_field :: 'a fract  _)"
definition [simp]: "euclidean_size_fract = (euclidean_size_field :: 'a fract  _)"
definition [simp]: "modulo_fract = (mod_field :: 'a fract  _)"

instance by standard (simp_all add: dvd_field_iff divide_simps)

end

instantiation fract :: (idom) euclidean_ring_gcd
begin

definition gcd_fract :: "'a fract  'a fract  'a fract" where
  "gcd_fract  Euclidean_Algorithm.gcd"
definition lcm_fract :: "'a fract  'a fract  'a fract" where
  "lcm_fract  Euclidean_Algorithm.lcm"
definition Gcd_fract :: "'a fract set  'a fract" where
 "Gcd_fract  Euclidean_Algorithm.Gcd"
definition Lcm_fract :: "'a fract set  'a fract" where
 "Lcm_fract  Euclidean_Algorithm.Lcm"

instance
  by (standard, simp_all add: gcd_fract_def lcm_fract_def Gcd_fract_def Lcm_fract_def)

end
(*field + unique_euclidean_ring + euclidean_ring_gcd + normalization_semidom_multiplicative*)

instantiation fract :: (idom) unique_euclidean_ring
begin

definition [simp]: "division_segment_fract (x :: 'a fract) = (1 :: 'a fract)"

instance by standard (auto split: if_splits)
end

instance fract :: (idom) field_gcd by standard auto


definition divides_ff :: "'a::idom fract  'a fract  bool"
  where "divides_ff x y   r. y = x * to_fract r"

lemma ff_list_pairs: 
  " xs. X = map (λ (x,y). Fraction_Field.Fract x y) xs  0  snd ` set xs"
proof (induct X)
  case (Cons a X)
  from Cons(1) obtain xs where X: "X = map (λ (x,y). Fraction_Field.Fract x y)  xs" and xs: "0  snd ` set xs"
    by auto
  obtain x y where a: "a = Fraction_Field.Fract x y" and y: "y  0" by (cases a, auto)
  show ?case unfolding X a using xs y
    by (intro exI[of _ "(x,y) # xs"], auto)
qed auto

lemma divides_ff_to_fract[simp]: "divides_ff (to_fract x) (to_fract y)  x dvd y"
  unfolding divides_ff_def dvd_def
  by (simp add: to_fract_def eq_fract(1) mult.commute)

lemma
  shows divides_ff_mult_cancel_left[simp]: "divides_ff (z * x) (z * y)  z = 0  divides_ff x y"
    and divides_ff_mult_cancel_right[simp]: "divides_ff (x * z) (y * z)  z = 0  divides_ff x y"
  unfolding divides_ff_def by auto

definition gcd_ff_list :: "'a::ufd fract list  'a fract  bool" where
  "gcd_ff_list X g = (
     ( x  set X. divides_ff g x)  
     ( d. ( x  set X. divides_ff d x)  divides_ff d g))"

lemma gcd_ff_list_exists: " g. gcd_ff_list (X :: 'a::ufd fract list) g"
proof -
  interpret some_gcd: idom_gcd "(*)" "1 :: 'a" "(+)" 0 "(-)" uminus some_gcd
    rewrites "dvd.dvd ((*)) = (dvd)" by (unfold_locales, auto simp: dvd_rewrites)
  from ff_list_pairs[of X] obtain xs where X: "X = map (λ (x,y). Fraction_Field.Fract x y) xs"
    and xs: "0  snd ` set xs" by auto
  define r where "r  prod_list (map snd xs)"
  have r: "r  0" unfolding r_def prod_list_zero_iff using xs by auto
  define ys where "ys  map (λ (x,y). x * prod_list (remove1 y (map snd xs))) xs"
  {
    fix i
    assume "i < length X"
    hence i: "i < length xs" unfolding X by auto
    obtain x y where xsi: "xs ! i = (x,y)" by force
    with i have "(x,y)  set xs" unfolding set_conv_nth by force
    hence y_mem: "y  set (map snd xs)" by force
    with xs have y: "y  0" by force
    from i have id1: "ys ! i = x * prod_list (remove1 y (map snd xs))" unfolding ys_def using xsi by auto
    from i xsi have id2: "X ! i = Fraction_Field.Fract x y" unfolding X by auto
    have lp: "prod_list (remove1 y (map snd xs)) * y = r" unfolding r_def
      by (rule prod_list_remove1[OF y_mem])
    have "ys ! i  set ys" using i unfolding ys_def by auto
    moreover have "to_fract (ys ! i) = to_fract r * (X ! i)"
      unfolding id1 id2 to_fract_def mult_fract
      by (subst eq_fract(1), force, force simp: y, simp add: lp)
    ultimately have "ys ! i  set ys" "to_fract (ys ! i) = to_fract r * (X ! i)" .
  } note ys = this
  define G where "G  some_gcd.listgcd ys"
  define g where "g  to_fract G * Fraction_Field.Fract 1 r"
  have len: "length X = length ys" unfolding X ys_def by auto
  show ?thesis
  proof (rule exI[of _ g], unfold gcd_ff_list_def, intro ballI conjI impI allI)
    fix x
    assume "x  set X"
    then obtain i where i: "i < length X" and x: "x = X ! i" unfolding set_conv_nth by auto
    from ys[OF i] have id: "to_fract (ys ! i) = to_fract r * x" 
      and ysi: "ys ! i  set ys" unfolding x by auto
    from some_gcd.listgcd[OF ysi] have "G dvd ys ! i" unfolding G_def .
    then obtain d where ysi: "ys ! i = G * d" unfolding dvd_def by auto
    have "to_fract d * (to_fract G * Fraction_Field.Fract 1 r) = x * (to_fract r * Fraction_Field.Fract 1 r)" 
      using id[unfolded ysi]
      by (simp add: ac_simps)
    also have " = x" using r unfolding to_fract_def by (simp add: eq_fract One_fract_def)
    finally have "to_fract d * (to_fract G * Fraction_Field.Fract 1 r) = x" by simp
    thus "divides_ff g x" unfolding divides_ff_def g_def 
      by (intro exI[of _ d], auto)
  next
    fix d
    assume "x  set X. divides_ff d x"
    hence "Ball ((λ x. to_fract r * x) ` set X) ( divides_ff (to_fract r * d))" by simp
    also have "(λ x. to_fract r * x) ` set X = to_fract ` set ys"
      unfolding set_conv_nth using ys len by force
    finally have dvd: "Ball (set ys) (λ y. divides_ff (to_fract r * d) (to_fract y))" by auto
    obtain nd dd where d: "d = Fraction_Field.Fract nd dd" and dd: "dd  0" by (cases d, auto)
    {
      fix y
      assume "y  set ys"
      hence "divides_ff (to_fract r * d) (to_fract y)" using dvd by auto
      from this[unfolded divides_ff_def d to_fract_def mult_fract]
      obtain ra where "Fraction_Field.Fract y 1 = Fraction_Field.Fract (r * nd * ra) dd" by auto
      hence "y * dd = ra * (r * nd)" by (simp add: eq_fract dd)
      hence "r * nd dvd y * dd" by auto
    }
    hence "r * nd dvd some_gcd.listgcd ys * dd" by (rule some_gcd.listgcd_greatest_mult)
    hence "divides_ff (to_fract r * d) (to_fract G)" unfolding to_fract_def d mult_fract
      G_def divides_ff_def by (auto simp add: eq_fract dd dvd_def)
    also have "to_fract G = to_fract r * g" unfolding g_def using r
      by (auto simp: to_fract_def eq_fract)
    finally show "divides_ff d g" using r by simp
  qed
qed

definition some_gcd_ff_list :: "'a :: ufd fract list  'a fract" where
  "some_gcd_ff_list xs = (SOME g. gcd_ff_list xs g)"

lemma some_gcd_ff_list: "gcd_ff_list xs (some_gcd_ff_list xs)"
  unfolding some_gcd_ff_list_def using gcd_ff_list_exists[of xs]
  by (rule someI_ex)

lemma some_gcd_ff_list_divides: "x  set xs  divides_ff (some_gcd_ff_list xs) x"
  using some_gcd_ff_list[of xs] unfolding gcd_ff_list_def by auto

lemma some_gcd_ff_list_greatest: "(x  set xs. divides_ff d x)  divides_ff d (some_gcd_ff_list xs)"
  using some_gcd_ff_list[of xs] unfolding gcd_ff_list_def by auto

lemma divides_ff_refl[simp]: "divides_ff x x"
  unfolding divides_ff_def
  by (rule exI[of _ 1], auto simp: to_fract_def One_fract_def)

lemma divides_ff_trans:
  "divides_ff x y  divides_ff y z  divides_ff x z"
  unfolding divides_ff_def
  by (auto simp del: to_fract_hom.hom_mult simp add: to_fract_hom.hom_mult[symmetric])

lemma divides_ff_mult_right: "a  0  divides_ff (x * inverse a) y  divides_ff x (a * y)"
  unfolding divides_ff_def divide_inverse[symmetric] by auto

definition eq_dff :: "'a :: ufd fract  'a fract  bool" (infix "=dff" 50) where
  "x =dff y  divides_ff x y  divides_ff y x"

lemma eq_dffI[intro]: "divides_ff x y  divides_ff y x  x =dff y" 
  unfolding eq_dff_def by auto

lemma eq_dff_refl[simp]: "x =dff x"
  by (intro eq_dffI, auto)

lemma eq_dff_sym: "x =dff y  y =dff x" unfolding eq_dff_def by auto

lemma eq_dff_trans[trans]: "x =dff y  y =dff z  x =dff z"
  unfolding eq_dff_def using divides_ff_trans by auto

lemma eq_dff_cancel_right[simp]: "x * y =dff x * z  x = 0  y =dff z" 
  unfolding eq_dff_def by auto

lemma eq_dff_mult_right_trans[trans]: "x =dff y * z  z =dff u  x =dff y * u"
  using eq_dff_trans by force

lemma some_gcd_ff_list_smult: "a  0  some_gcd_ff_list (map ((*) a) xs) =dff a * some_gcd_ff_list xs"
proof 
  let ?g = "some_gcd_ff_list (map ((*) a) xs)"
  show "divides_ff (a * some_gcd_ff_list xs) ?g"
    by (rule some_gcd_ff_list_greatest, insert some_gcd_ff_list_divides[of _ xs], auto simp: divides_ff_def)
  assume a: "a  0"
  show "divides_ff ?g (a * some_gcd_ff_list xs)"
  proof (rule divides_ff_mult_right[OF a some_gcd_ff_list_greatest], intro ballI)
    fix x
    assume x: "x  set xs"
    have "divides_ff (?g * inverse a) x = divides_ff (inverse a * ?g) (inverse a * (a * x))"
      using a by (simp add: field_simps)
    also have "" using a x by (auto intro: some_gcd_ff_list_divides)
    finally show "divides_ff (?g * inverse a) x" .
  qed
qed

definition content_ff :: "'a::ufd fract poly  'a fract" where 
  "content_ff p = some_gcd_ff_list (coeffs p)"

lemma content_ff_iff: "divides_ff x (content_ff p)  ( c  set (coeffs p). divides_ff x c)" (is "?l = ?r")
proof
  assume ?l
  from divides_ff_trans[OF this, unfolded content_ff_def, OF some_gcd_ff_list_divides] show ?r ..
next
  assume ?r
  thus ?l unfolding content_ff_def by (intro some_gcd_ff_list_greatest, auto)
qed

lemma content_ff_divides_ff: "x  set (coeffs p)  divides_ff (content_ff p) x"
  unfolding content_ff_def by (rule some_gcd_ff_list_divides)

lemma content_ff_0[simp]: "content_ff 0 = 0"
  using content_ff_iff[of 0 0] by (auto simp: divides_ff_def)

lemma content_ff_0_iff[simp]: "(content_ff p = 0) = (p = 0)"
proof (cases "p = 0")
  case False
  define a where "a  last (coeffs p)"
  define xs where "xs  coeffs p"
  from False
  have mem: "a  set (coeffs p)" and a: "a  0"
    unfolding a_def last_coeffs_eq_coeff_degree[OF False] coeffs_def by auto
  from content_ff_divides_ff[OF mem] have "divides_ff (content_ff p) a" .
  with a have "content_ff p  0" unfolding divides_ff_def by auto
  with False show ?thesis by auto
qed auto

lemma content_ff_eq_dff_nonzero: "content_ff p =dff x  x  0  p  0"
  using divides_ff_def eq_dff_def by force

lemma content_ff_smult: "content_ff (smult (a::'a::ufd fract) p) =dff a * content_ff p"
proof (cases "a = 0")
  case False note a = this
  have id: "coeffs (smult a p) = map ((*) a) (coeffs p)"
    unfolding coeffs_smult using a by (simp add: Polynomial.coeffs_smult)
  show ?thesis unfolding content_ff_def id using some_gcd_ff_list_smult[OF a] .
qed simp

definition normalize_content_ff
  where "normalize_content_ff (p::'a::ufd fract poly)  smult (inverse (content_ff p)) p"

lemma smult_normalize_content_ff: "smult (content_ff p) (normalize_content_ff p) = p"  
  unfolding normalize_content_ff_def
  by (cases "p = 0", auto)

lemma content_ff_normalize_content_ff_1: assumes p0: "p  0" 
  shows "content_ff (normalize_content_ff p) =dff 1"
proof -
  have "content_ff p = content_ff (smult (content_ff p) (normalize_content_ff p))" unfolding smult_normalize_content_ff ..
  also have " =dff content_ff p * content_ff (normalize_content_ff p)" by (rule content_ff_smult)
  finally show ?thesis unfolding eq_dff_def divides_ff_def using p0 by auto
qed

lemma content_ff_to_fract: assumes "set (coeffs p)  range to_fract"
  shows "content_ff p  range to_fract"
proof -
  have "divides_ff 1 (content_ff p)" using assms
    unfolding content_ff_iff unfolding divides_ff_def[abs_def] by auto
  thus ?thesis unfolding divides_ff_def by auto
qed

lemma content_ff_map_poly_to_fract: "content_ff (map_poly to_fract (p :: 'a :: ufd poly))  range to_fract"
  by (rule content_ff_to_fract, subst coeffs_map_poly, auto)

lemma range_coeffs_to_fract: assumes "set (coeffs p)  range to_fract" 
  shows " m. coeff p i = to_fract m"
proof -
  from assms(1) to_fract_0 have "coeff p i  range to_fract" using range_coeff [of p]
    by auto (metis contra_subsetD to_fract_hom.hom_zero insertE range_eqI)
  thus ?thesis by auto
qed

lemma divides_ff_coeff: assumes "set (coeffs p)  range to_fract" and "divides_ff (to_fract n) (coeff p i)"
  shows " m. coeff p i = to_fract n * to_fract m"
proof -
  from range_coeffs_to_fract[OF assms(1)]  obtain k where pi: "coeff p i = to_fract k" by auto
  from assms(2)[unfolded this] have "n dvd k" by simp
  then obtain j where k: "k = n * j" unfolding Rings.dvd_def by auto
  show ?thesis unfolding pi k by auto
qed

definition inv_embed :: "'a :: ufd fract  'a" where
  "inv_embed = the_inv to_fract"

lemma inv_embed[simp]: "inv_embed (to_fract x) = x"
  unfolding inv_embed_def
  by (rule the_inv_f_f, auto simp: inj_on_def)

lemma inv_embed_0[simp]: "inv_embed 0 = 0" unfolding to_fract_0[symmetric] inv_embed by simp

lemma range_to_fract_embed_poly: assumes "set (coeffs p)  range to_fract"
  shows "p = map_poly to_fract (map_poly inv_embed p)"
proof -
  have "p = map_poly (to_fract o inv_embed) p"
    by (rule sym, rule map_poly_idI, insert assms, auto)
  also have " = map_poly to_fract (map_poly inv_embed p)" 
    by (subst map_poly_map_poly, auto)
  finally show ?thesis .
qed

lemma content_ff_to_fract_coeffs_to_fract: assumes "content_ff p  range to_fract"
  shows "set (coeffs p)  range to_fract"
proof 
  fix x
  assume "x  set (coeffs p)"
  from content_ff_divides_ff[OF this] assms[unfolded eq_dff_def] show "x  range to_fract"
    unfolding divides_ff_def by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
qed

lemma content_ff_1_coeffs_to_fract: assumes "content_ff p =dff 1"
  shows "set (coeffs p)  range to_fract"
proof 
  fix x
  assume "x  set (coeffs p)"
  from content_ff_divides_ff[OF this] assms[unfolded eq_dff_def] show "x  range to_fract"
    unfolding divides_ff_def by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
qed

lemma gauss_lemma:
  fixes p q :: "'a :: ufd fract poly"
  shows "content_ff (p * q) =dff content_ff p * content_ff q"
proof (cases "p = 0  q = 0")
  case False
  hence p: "p  0" and q: "q  0" by auto
  let ?c = "content_ff :: 'a fract poly  'a fract"
  {
    fix p q :: "'a fract poly"
    assume cp1: "?c p =dff 1" and cq1: "?c q =dff 1"
    define ip where "ip  map_poly inv_embed p"
    define iq where "iq  map_poly inv_embed q"
    interpret map_poly_hom: map_poly_comm_ring_hom to_fract..
    from content_ff_1_coeffs_to_fract[OF cp1] have cp: "set (coeffs p)  range to_fract" .
    from content_ff_1_coeffs_to_fract[OF cq1] have cq: "set (coeffs q)  range to_fract" .
    have ip: "p = map_poly to_fract ip" unfolding ip_def
      by (rule range_to_fract_embed_poly[OF cp])
    have iq: "q = map_poly to_fract iq" unfolding iq_def
      by (rule range_to_fract_embed_poly[OF cq])
    have cpq0: "?c (p * q)  0"
      unfolding content_ff_0_iff using cp1 cq1 content_ff_eq_dff_nonzero[of _ 1] by auto
    have cpq: "set (coeffs (p * q))  range to_fract" unfolding ip iq
    unfolding map_poly_hom.hom_mult[symmetric] to_fract_hom.coeffs_map_poly_hom by auto
    have ctnt: "?c (p * q)  range to_fract" using content_ff_to_fract[OF cpq] .
    then obtain cpq where id: "?c (p * q) = to_fract cpq" by auto
    have dvd: "divides_ff 1 (?c (p * q))" using ctnt unfolding divides_ff_def by auto
    from cpq0[unfolded id] have cpq0: "cpq  0" unfolding to_fract_def Zero_fract_def by auto
    hence cpqM: "cpq  carrier mk_monoid" by auto
    have "?c (p * q) =dff 1"
    proof (rule ccontr)
      assume "¬ ?c (p * q) =dff 1"
      with dvd have "¬ divides_ff (?c (p * q)) 1"
        unfolding eq_dff_def by auto
      from this[unfolded id divides_ff_def] have cpq: " r. cpq * r  1" 
        by (auto simp: to_fract_def One_fract_def eq_fract)
      then have cpq1: "¬ cpq dvd 1" by (auto elim:dvdE simp:ac_simps)
      from mset_factors_exist[OF cpq0 cpq1]
      obtain F where F: "mset_factors F cpq" by auto
      have "F  {#}" using F by auto
      then obtain f where f: "f ∈# F" by auto
      with F have irrf: "irreducible f" and f0: "f  0" by (auto dest: mset_factorsD)
      from irrf have pf: "prime_elem f" by simp
      note * = this[unfolded prime_elem_def]
      from * have no_unit: "¬ f dvd 1" by auto
      from * f0 have prime: " a b. f dvd a * b  f dvd a  f dvd b" unfolding dvd_def by force
      let ?f = "to_fract f"
      from F f
      have fdvd: "f dvd cpq" by (auto intro:mset_factors_imp_dvd)
      hence "divides_ff ?f (to_fract cpq)" by simp
      from divides_ff_trans[OF this, folded id, OF content_ff_divides_ff] 
      have dvd: " z. z  set (coeffs (p * q))  divides_ff ?f z" .
      {
        fix p :: "'a fract poly"
        assume cp: "?c p =dff 1" 
        let ?P = "λ i. ¬ divides_ff ?f (coeff p i)"
        {
          assume " c  set (coeffs p). divides_ff ?f c"           
          hence n: "divides_ff ?f (?c p)" unfolding content_ff_iff by auto
          from divides_ff_trans[OF this] cp[unfolded eq_dff_def] have "divides_ff ?f 1" by auto
          also have "1 = to_fract 1" by simp
          finally have "f dvd 1" by (unfold divides_ff_to_fract)
          hence False using no_unit unfolding dvd_def by (auto simp: ac_simps)
        }
        then obtain cp where cp: "cp  set (coeffs p)" and ncp: "¬ divides_ff ?f cp" by auto
        hence "cp  range (coeff p)" unfolding range_coeff by auto
        with ncp have " i. ?P i" by auto
        from LeastI_ex[OF this] not_less_Least[of _ ?P]
        have " i. ?P i  ( j. j < i  divides_ff ?f (coeff p j))" by blast
      } note cont = this
      from cont[OF cp1] obtain r where 
        r: "¬ divides_ff ?f (coeff p r)" and r': " i. i < r  divides_ff ?f (coeff p i)" by auto
      have " i.  k. i < r  coeff p i = ?f * to_fract k" using divides_ff_coeff[OF cp r'] by blast
      from choice[OF this] obtain rr where r': " i. i < r  coeff p i = ?f * to_fract (rr i)" by blast
      let ?r = "coeff p r"
      from cont[OF cq1] obtain s where 
        s: "¬ divides_ff ?f (coeff q s)" and s': " i. i < s  divides_ff ?f (coeff q i)" by auto
      have " i.  k. i < s  coeff q i = ?f * to_fract k" using divides_ff_coeff[OF cq s'] by blast
      from choice[OF this] obtain ss where s': " i. i < s  coeff q i = ?f * to_fract (ss i)" by blast
      from range_coeffs_to_fract[OF cp] have " i.  m. coeff p i = to_fract m" ..
      from choice[OF this] obtain pi where pi: " i. coeff p i = to_fract (pi i)" by blast
      from range_coeffs_to_fract[OF cq] have " i.  m. coeff q i = to_fract m" ..
      from choice[OF this] obtain qi where qi: " i. coeff q i = to_fract (qi i)" by blast
      let ?s = "coeff q s"
      let ?g = "λ i. coeff p i * coeff q (r + s - i)"
      define a where "a = (i{..<r}. (rr i * qi (r + s - i)))"
      define b where "b = ( i  {Suc r..r + s}. pi i * (ss (r + s - i)))" 
      have "coeff (p * q) (r + s) = (ir + s. ?g i)" unfolding coeff_mult ..
      also have "{..r+s} = {..< r}  {r .. r+s}" by auto
      also have "(i{..<r}  {r..r + s}. ?g i)
        = (i{..<r}. ?g i) + ( i  {r..r + s}. ?g i)" 
        by (rule sum.union_disjoint, auto)
      also have "(i{..<r}. ?g i) = (i{..<r}. ?f * (to_fract (rr i) * to_fract (qi (r + s - i))))"
        by (rule sum.cong[OF refl], insert r' qi, auto)
      also have " = to_fract (f * a)" by (simp add: a_def sum_distrib_left)
      also have "( i  {r..r + s}. ?g i) = ?g r + ( i  {Suc r..r + s}. ?g i)"
        by (subst sum.remove[of _ r], auto intro: sum.cong)
      also have "( i  {Suc r..r + s}. ?g i) = ( i  {Suc r..r + s}. ?f * (to_fract (pi i) * to_fract (ss (r + s - i))))"
        by (rule sum.cong[OF refl], insert s' pi, auto)
      also have " = to_fract (f * b)" by (simp add: sum_distrib_left b_def)
      finally have cpq: "coeff (p * q) (r + s) = to_fract (f * (a + b)) + ?r * ?s" by (simp add: field_simps)
      {
        fix i
        from dvd[of "coeff (p * q) i"] have "divides_ff ?f (coeff (p * q) i)" using range_coeff[of "p * q"] 
          by (cases "coeff (p * q) i = 0", auto simp: divides_ff_def)
      }
      from this[of "r + s", unfolded cpq] have "divides_ff ?f (to_fract (f * (a + b) + pi r * qi s))" 
        unfolding pi qi by simp
      from this[unfolded divides_ff_to_fract] have "f dvd pi r * qi s"
        by (metis dvd_add_times_triv_left_iff mult.commute)
      from prime[OF this] have "f dvd pi r  f dvd qi s" by auto
      with r s show False unfolding pi qi by auto
    qed
  } note main = this
  define n where "n  normalize_content_ff :: 'a fract poly  'a fract poly"
  let ?s = "λ p. smult (content_ff p) (n p)"
  have "?c (p * q) = ?c (?s p * ?s q)" unfolding smult_normalize_content_ff n_def by simp
  also have "?s p * ?s q = smult (?c p * ?c q) (n p * n q)" by (simp add: mult.commute)
  also have "?c () =dff (?c p * ?c q) * ?c (n p * n q)" by (rule content_ff_smult)
  also have "?c (n p * n q) =dff 1" unfolding n_def
    by (rule main, insert p q, auto simp: content_ff_normalize_content_ff_1)
  finally show ?thesis by simp
qed auto

abbreviation (input) "content_ff_ff p  content_ff (map_poly to_fract p)"

lemma factorization_to_fract:
  assumes q: "q  0" and factor: "map_poly to_fract (p :: 'a :: ufd poly) = q * r"
  shows " q' r' c. c  0  q = smult c (map_poly to_fract q') 
    r = smult (inverse c) (map_poly to_fract r') 
    content_ff_ff q' =dff 1  p = q' * r'"
proof -
  let ?c = content_ff
  let ?p = "map_poly to_fract p"
  interpret map_poly_inj_comm_ring_hom "to_fract :: 'a  _"..
  define cq where "cq  normalize_content_ff q"
  define cr where "cr  smult (content_ff q) r"
  define q' where "q'  map_poly inv_embed cq"
  define r' where "r'  map_poly inv_embed cr"
  from content_ff_map_poly_to_fract have cp_ff: "?c ?p  range to_fract" by auto
  from smult_normalize_content_ff[of q] have cqs: "q = smult (content_ff q) cq" unfolding cq_def ..
  from content_ff_normalize_content_ff_1[OF q] have c_cq: "content_ff cq =dff 1" unfolding cq_def .
  from content_ff_1_coeffs_to_fract[OF this] have cq_ff: "set (coeffs cq)  range to_fract" .
  have factor: "?p = cq * cr" unfolding factor cr_def using cqs
    by (metis mult_smult_left mult_smult_right)
  from gauss_lemma[of cq cr] have cp: "?c ?p =dff ?c cq * ?c cr" unfolding factor .
  with c_cq have "?c ?p =dff ?c cr"
    by (metis eq_dff_mult_right_trans mult.commute mult.right_neutral)
  with cp_ff have "?c cr  range to_fract"
    by (metis divides_ff_def to_fract_hom.hom_mult eq_dff_def image_iff range_eqI)
  from content_ff_to_fract_coeffs_to_fract[OF this] have cr_ff: "set (coeffs cr)  range to_fract" by auto
  have cq: "cq = map_poly to_fract q'" unfolding q'_def
    by (rule range_to_fract_embed_poly[OF cq_ff])
  have cr: "cr = map_poly to_fract r'" unfolding r'_def
    by (rule range_to_fract_embed_poly[OF cr_ff])
  from factor[unfolded cq cr]
  have p: "p = q' * r'" by (simp add: injectivity)
  from c_cq have ctnt: "content_ff_ff q' =dff 1" using cq q'_def by force
  from cqs have idq: "q = smult (?c q) (map_poly to_fract q')" unfolding cq .
  with q have cq: "?c q  0" by auto
  have "r = smult (inverse (?c q)) cr" unfolding cr_def using cq by auto
  also have "cr = map_poly to_fract r'" by (rule cr)
  finally have idr: "r = smult (inverse (?c q)) (map_poly to_fract r')" by auto
  from cq p ctnt idq idr show ?thesis by blast
qed

lemma irreducible_PM_M_PFM:
  assumes irr: "irreducible p"
  shows "degree p = 0  irreducible (coeff p 0)  
  degree p  0  irreducible (map_poly to_fract p)  content_ff_ff p =dff 1"
proof-
  interpret map_poly_inj_idom_hom to_fract..
  from irr[unfolded irreducible_altdef]
  have p0: "p  0" and irr: "¬ p dvd 1" " b. b dvd p  ¬ p dvd b  b dvd 1" by auto
  show ?thesis
  proof (cases "degree p = 0")
    case True
    from degree0_coeffs[OF True] obtain a where p: "p = [:a:]" by auto
    note irr = irr[unfolded p]
    from p p0 have a0: "a  0" by auto
    moreover have "¬ a dvd 1" using irr(1) by simp
    moreover {
      fix b
      assume "b dvd a" "¬ a dvd b"
      hence "[:b:] dvd [:a:]" "¬ [:a:] dvd [:b:]" unfolding const_poly_dvd .
      from irr(2)[OF this] have "b dvd 1" unfolding const_poly_dvd_1 .
    }
    ultimately have "irreducible a" unfolding irreducible_altdef by auto
    with True show ?thesis unfolding p by auto
  next
    case False
    let ?E = "map_poly to_fract"
    let ?p = "?E p"
    have dp: "degree ?p  0" using False by simp
    from p0 have p': "?p  0" by simp
    moreover have "¬ ?p dvd 1" 
      proof
        assume "?p dvd 1" then obtain q where id: "?p * q = 1" unfolding dvd_def by auto
        have deg: "degree (?p * q) = degree ?p + degree q"
          by (rule degree_mult_eq, insert id, auto)
        from arg_cong[OF id, of degree, unfolded deg] dp show False by auto
      qed
    moreover {
      fix q
      assume "q dvd ?p" and ndvd: "¬ ?p dvd q"
      then obtain r where fact: "?p = q * r" unfolding dvd_def by auto
      with p' have q0: "q  0" by auto
      from factorization_to_fract[OF this fact] obtain q' r' c where *: "c  0" "q = smult c (?E q')"
        "r = smult (inverse c) (?E r')" "content_ff_ff q' =dff 1"
        "p = q' * r'" by auto
      hence "q' dvd p" unfolding dvd_def by auto
      note irr = irr(2)[OF this]
      have "¬ p dvd q'"
      proof
        assume "p dvd q'"
        then obtain u where q': "q' = p * u" unfolding dvd_def by auto
        from arg_cong[OF this, of "λ x. smult c (?E x)", unfolded *(2)[symmetric]]
        have "q = ?p * smult c (?E u)" by simp
        hence "?p dvd q" unfolding dvd_def by blast
        with ndvd show False ..
      qed
      from irr[OF this] have "q' dvd 1" .
      from divides_degree[OF this] have "degree q' = 0" by auto
      from degree0_coeffs[OF this] obtain a' where "q' = [:a':]" by auto
      from *(2)[unfolded this] obtain a where q: "q = [:a:]"
        by (simp add: to_fract_hom.map_poly_pCons_hom)
      with q0 have a: "a  0" by auto
      have "q dvd 1" unfolding q const_poly_dvd_1 using a unfolding dvd_def
        by (intro exI[of _ "inverse a"], auto)
    }
    ultimately have irr_p': "irreducible ?p" unfolding irreducible_altdef by auto
    let ?c = "content_ff"
    have "?c ?p  range to_fract"
      by (rule content_ff_to_fract, unfold to_fract_hom.coeffs_map_poly_hom, auto)
    then obtain c where cp: "?c ?p = to_fract c" by auto
    from p' cp have c: "c  0" by auto
    have "?c ?p =dff 1" unfolding cp
    proof (rule ccontr)
      define cp where "cp = normalize_content_ff ?p"
      from smult_normalize_content_ff[of ?p] have cps: "?p = smult (to_fract c) cp" unfolding cp_def cp ..
      from content_ff_normalize_content_ff_1[OF p'] have c_cp: "content_ff cp =dff 1" unfolding cp_def .
      from range_to_fract_embed_poly[OF content_ff_1_coeffs_to_fract[OF c_cp]] obtain cp' where "cp = ?E cp'" by auto
      from cps[unfolded this] have "p = smult c cp'" by (simp add: injectivity)
      hence dvd: "[: c :] dvd p" unfolding dvd_def by auto
      have "¬ p dvd [: c :]" using divides_degree[of p "[: c :]"] c False by auto
      from irr(2)[OF dvd this] have "c dvd 1" by simp
      assume "¬ to_fract c =dff 1"
      from this[unfolded eq_dff_def One_fract_def to_fract_def[symmetric] divides_ff_def to_fract_mult]
      have c1: " r. 1  c * r" by (auto simp: ac_simps simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
      with c dvd 1 show False unfolding dvd_def by blast
    qed
    with False irr_p' show ?thesis by auto
  qed
qed

lemma irreducible_M_PM:
  fixes p :: "'a :: ufd poly" assumes 0: "degree p = 0" and irr: "irreducible (coeff p 0)"
  shows "irreducible p"
proof (cases "p = 0")
  case True
  thus ?thesis using assms by auto
next
  case False
  from degree0_coeffs[OF 0] obtain a where p: "p = [:a:]" by auto
  with False have a0: "a  0" by auto
  from p irr have "irreducible a" by auto
  from this[unfolded irreducible_altdef]
  have a1: "¬ a dvd 1" and irr: " b. b dvd a  ¬ a dvd b  b dvd 1" by auto
  { 
    fix b
    assume *: "b dvd [:a:]" "¬ [:a:] dvd b"
    from divides_degree[OF this(1)] a0 have "degree b = 0" by auto
    from degree0_coeffs[OF this] obtain bb where b: "b = [: bb :]" by auto
    from * irr[of bb] have "b dvd 1" unfolding b const_poly_dvd by auto
  }
  with a0 a1 show ?thesis by (auto simp: irreducible_altdef p)
qed

lemma primitive_irreducible_imp_degree:
 "primitive (p::'a::{semiring_gcd,idom} poly)  irreducible p  degree p > 0"
  by (unfold irreducible_primitive_connect[symmetric], auto)

lemma irreducible_degree_field:
  fixes p :: "'a :: field poly" assumes "irreducible p"
  shows "degree p > 0"
proof-
  {
    assume "degree p = 0"
    from degree0_coeffs[OF this] assms obtain a where p: "p = [:a:]" and a: "a  0" by auto
    hence "1 = p * [:inverse a:]" by auto
    hence "p dvd 1" ..
    hence "p  Units mk_monoid" by simp
    with assms have False unfolding irreducible_def by auto
  } then show ?thesis by auto
qed

lemma irreducible_PFM_PM: assumes
  irr: "irreducible (map_poly to_fract p)" and ct: "content_ff_ff p =dff 1"
  shows "irreducible p"
proof -
  let ?E = "map_poly to_fract"
  let ?p = "?E p"
  from ct have p0: "p  0" by (auto simp: eq_dff_def divides_ff_def)
  moreover
    from irreducible_degree_field[OF irr] have deg: "degree p  0" by simp
    from irr[unfolded irreducible_altdef]
    have irr: " b. b dvd ?p  ¬ ?p dvd b  b dvd 1" by auto
    have "¬ p dvd 1" using deg divides_degree[of p 1] by auto
  moreover {
    fix q :: "'a poly"
    assume dvd: "q dvd p" and ndvd: "¬ p dvd q"
    from dvd obtain r where pqr: "p = q * r" ..
    from arg_cong[OF this, of ?E] have pqr': "?p = ?E q * ?E r" by simp
    from p0 pqr have q: "q  0" and r: "r  0" by auto
    have dp: "degree p = degree q + degree r" unfolding pqr
      by (subst degree_mult_eq, insert q r, auto)
    from eq_dff_trans[OF eq_dff_sym[OF gauss_lemma[of "?E q" "?E r", folded pqr']] ct]
    have ct: "content_ff (?E q) * content_ff (?E r) =dff 1" .
    from content_ff_map_poly_to_fract obtain cq where cq: "content_ff (?E q) = to_fract cq" by auto
    from content_ff_map_poly_to_fract obtain cr where cr: "content_ff (?E r) = to_fract cr" by auto
    note ct[unfolded cq cr to_fract_mult eq_dff_def divides_ff_def]
    from this[folded hom_distribs]
    obtain c where c: "cq * cr * c = 1" by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
    hence one: "1 = cq * (c * cr)" "1 = cr * (c * cq)" by (auto simp: ac_simps)
    {
      assume *: "degree q  0  degree r  0"
      with dp have "degree q < degree p" by auto
      hence "degree (?E q) < degree (?E p)" by simp
      hence ndvd: "¬ ?p dvd ?E q" using divides_degree[of ?p "?E q"] q by auto
      have "?E q dvd ?p" unfolding pqr' by auto
      from irr[OF this ndvd] have "?E q dvd 1" .
      from divides_degree[OF this] * have False by auto
    }
    hence "degree q = 0  degree r = 0" by blast
    then have "q dvd 1" 
    proof
      assume "degree q = 0"
      from degree0_coeffs[OF this] q obtain a where q: "q = [:a:]" and a: "a  0" by auto
      hence id: "set (coeffs (?E q)) = {to_fract a}" by auto
      have "divides_ff (to_fract a) (content_ff (?E q))" unfolding content_ff_iff id by auto
      from this[unfolded cq divides_ff_def, folded hom_distribs]
      obtain rr where cq: "cq = a * rr" by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
      with one(1) have "1 = a * (rr * c * cr)" by (auto simp: ac_simps)
      hence "a dvd 1" ..
      thus ?thesis by (simp add: q)
    next
      assume "degree r = 0"
      from degree0_coeffs[OF this] r obtain a where r: "r = [:a:]" and a: "a  0" by auto
      hence id: "set (coeffs (?E r)) = {to_fract a}" by auto
      have "divides_ff (to_fract a) (content_ff (?E r))" unfolding content_ff_iff id by auto
      note this[unfolded cr divides_ff_def to_fract_mult]
      note this[folded hom_distribs]
      then obtain rr where cr: "cr = a * rr" by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
      with one(2) have one: "1 = a * (rr * c * cq)" by (auto simp: ac_simps)
      from arg_cong[OF pqr[unfolded r], of "λ p. p * [:rr * c * cq:]"]
      have "p * [:rr * c * cq:] = q * [:a * (rr * c * cq):]" by (simp add: ac_simps)
      also have " = q" unfolding one[symmetric] by auto
      finally obtain r where "q = p * r" by blast
      hence "p dvd q" ..
      with ndvd show ?thesis by auto
    qed
  }
  ultimately show ?thesis by (auto simp:irreducible_altdef)
qed

lemma irreducible_cases: "irreducible p 
  degree p = 0  irreducible (coeff p 0)  
  degree p  0  irreducible (map_poly to_fract p)  content_ff_ff p =dff 1"
  using irreducible_PM_M_PFM irreducible_M_PM irreducible_PFM_PM
  by blast

lemma dvd_PM_iff: "p dvd q  divides_ff (content_ff_ff p) (content_ff_ff q)  
  map_poly to_fract p dvd map_poly to_fract q"
proof -
  interpret map_poly_inj_idom_hom to_fract..
  let ?E = "map_poly to_fract"
  show ?thesis (is "?l = ?r")
  proof
    assume "p dvd q"
    then obtain r where qpr: "q = p * r" ..
    from arg_cong[OF this, of ?E]
    have dvd: "?E p dvd ?E q" by auto
    from content_ff_map_poly_to_fract obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
    from content_ff_map_poly_to_fract obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
    from content_ff_map_poly_to_fract obtain cr where cr: "content_ff_ff r = to_fract cr" by auto
    from gauss_lemma[of "?E p" "?E r", folded hom_distribs qpr, unfolded cq cp cr]
    have "divides_ff (content_ff_ff p) (content_ff_ff q)" unfolding cq cp eq_dff_def
      by (metis divides_ff_def divides_ff_trans)
    with dvd show ?r by blast
  next
    assume ?r
    show ?l 
    proof (cases "q = 0")
      case True
      with ?r show ?l by auto
    next
      case False note q = this
      hence q': "?E q  0" by auto
      from ?r obtain rr where qpr: "?E q = ?E p * rr" unfolding dvd_def by auto
      with q have p: "p  0" and Ep: "?E p  0" and rr: "rr  0" by auto
      from gauss_lemma[of "?E p" rr, folded qpr] 
      have ct: "content_ff_ff q =dff content_ff_ff p * content_ff rr"
        by auto
      from content_ff_map_poly_to_fract[of p] obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
      from content_ff_map_poly_to_fract[of q] obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
      from ?r[unfolded cp cq] have "divides_ff (to_fract cp) (to_fract cq)" ..
      with ct[unfolded cp cq eq_dff_def] have "content_ff rr  range to_fract"
        by (metis (no_types, lifting) Ep content_ff_0_iff cp divides_ff_def 
          divides_ff_trans mult.commute mult_right_cancel range_eqI)
      from range_to_fract_embed_poly[OF content_ff_to_fract_coeffs_to_fract[OF this]] obtain r
        where rr: "rr = ?E r" by auto
      from qpr[unfolded rr, folded hom_distribs]
      have "q = p * r" by (rule injectivity)
      thus "p dvd q" ..
    qed
  qed
qed

lemma factorial_monoid_poly: "factorial_monoid (mk_monoid :: 'a :: ufd poly monoid)"
proof (fold factorial_condition_one, intro conjI)
  interpret M: factorial_monoid "mk_monoid :: 'a monoid" by (fact factorial_monoid)
  interpret PFM: factorial_monoid "mk_monoid :: 'a fract poly monoid" 
    by (rule as_ufd.factorial_monoid)
  interpret PM: comm_monoid_cancel "mk_monoid :: 'a poly monoid" by (unfold_locales, auto)
  let ?E = "map_poly to_fract"
  show "divisor_chain_condition_monoid (mk_monoid::'a poly monoid)"
  proof (unfold_locales, unfold mk_monoid_simps)
    let ?rel' = "{(x::'a poly, y). x  0  y  0  properfactor x y}"
    let ?rel'' = "{(x::'a, y). x  0  y  0  properfactor x y}"
    let ?relPM = "{(x, y). x  0  y  0  x dvd y  ¬ y dvd (x :: 'a poly)}"
    let ?relM = "{(x, y). x  0  y  0  x dvd y  ¬ y dvd (x :: 'a)}"
    have id: "?rel' = ?relPM" using properfactor_nz by auto
    have id': "?rel'' = ?relM" using properfactor_nz by auto
    have "wf ?rel''" using M.division_wellfounded by auto
    hence wfM: "wf ?relM" using id' by auto
    let ?c = "λ p. inv_embed (content_ff_ff p)"
    let ?f = "λ p. (degree p, ?c p)"
    note wf = wf_inv_image[OF wf_lex_prod[OF wf_less wfM], of ?f]
    show "wf ?rel'" unfolding id
    proof (rule wf_subset[OF wf], clarify)
      fix p q :: "'a poly"
      assume p: "p  0" and q: "q  0" and dvd: "p dvd q" and ndvd: "¬ q dvd p"
      from dvd obtain r where qpr: "q = p * r" ..
      from degree_mult_eq[of p r, folded qpr] q qpr have r: "r  0" 
        and deg: "degree q = degree p + degree r" by auto
      show "(p,q)  inv_image ({(x, y). x < y} <*lex*> ?relM) ?f"
      proof (cases "degree p = degree q")
        case False
        with deg have "degree p < degree q" by auto
        thus ?thesis by auto
      next
        case True
        with deg have "degree r = 0" by simp
        from degree0_coeffs[OF this] r obtain a where ra: "r = [:a:]" and a: "a  0" by auto
        from arg_cong[OF qpr, of "λ p. ?E p * [:inverse (to_fract a):]"] a
        have "?E p = ?E q * [:inverse (to_fract a):]"
          by (auto simp: ac_simps ra)
        hence "?E q dvd ?E p" ..
        with ndvd dvd_PM_iff have ndvd: "¬ divides_ff (content_ff_ff q) (content_ff_ff p)" by auto
        from content_ff_map_poly_to_fract obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
        from content_ff_map_poly_to_fract obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
        from ndvd[unfolded cp cq] have ndvd: "¬ cq dvd cp" by simp
        from iffD1[OF dvd_PM_iff,OF dvd,unfolded cq cp]
        have dvd: "cp dvd cq" by simp
        have c_p: "?c p = cp" unfolding cp by simp
        have c_q: "?c q = cq" unfolding cq by simp
        from q cq have cq0: "cq  0" by auto
        from p cp have cp0: "cp  0" by auto
        from ndvd cq0 cp0 dvd have "(?c p, ?c q)  ?relM" unfolding c_p c_q by auto
        with True show ?thesis by auto
      qed
    qed
  qed
  show "primeness_condition_monoid (mk_monoid::'a poly monoid)"
  proof (unfold_locales, unfold mk_monoid_simps)
    fix p :: "'a poly"
    assume p: "p  0" and "irred p"
    then have irr: "irreducible p" by auto
    from p have p': "?E p  0" by auto
    from irreducible_PM_M_PFM[OF irr] have choice: "degree p = 0  irred (coeff p 0)
       degree p  0  irred (?E p)  content_ff_ff p =dff 1" by auto
    show "Divisibility.prime mk_monoid p"
    proof (rule Divisibility.primeI, unfold mk_monoid_simps mem_Units)
      show "¬ p dvd 1"
      proof
        assume "p dvd 1"
        from divides_degree[OF this] have dp: "degree p = 0" by auto
        from degree0_coeffs[OF this] p obtain a where p: "p = [:a:]" and a: "a  0" by auto
        with choice have irr: "irreducible a" by auto
        from p dvd 1[unfolded p] have "a dvd 1" by auto
        with irr show False unfolding irreducible_def by auto
      qed
      fix q r :: "'a poly"
      assume q: "q  0" and r: "r  0" and "factor p (q * r)"
      from this[unfolded factor_idom] have "p dvd q * r" by auto
      from iffD1[OF dvd_PM_iff this] have dvd_ct: "divides_ff (content_ff_ff p) (content_ff (?E (q * r)))"
        and dvd_E: "?E p dvd ?E q * ?E r" by auto
      from gauss_lemma[of "?E q" "?E r"] divides_ff_trans[OF dvd_ct, of "content_ff_ff q * content_ff_ff r"]
      have dvd_ct: "divides_ff (content_ff_ff p) (content_ff_ff q * content_ff_ff r)"
        unfolding eq_dff_def by auto
      from choice
      have "p dvd q  p dvd r"
      proof
        assume "degree p  0  irred (?E p)  content_ff_ff p =dff 1"
        hence deg: "degree p  0" and irr: "irred (?E p)" and ct: "content_ff_ff p =dff 1" by auto
        from PFM.irreducible_prime[OF irr] p have prime: "Divisibility.prime mk_monoid (?E p)" by auto
        from q r have Eq: "?E q  carrier mk_monoid" and Er: "?E r  carrier mk_monoid" 
          and q': "?E q  0" and r': "?E r  0" and qr': "?E q * ?E r  0" by auto
        from PFM.prime_divides[OF Eq Er prime] q' r' qr' dvd_E
        have dvd_E: "?E p dvd ?E q  ?E p dvd ?E r" by simp
        from ct have ct: "divides_ff (content_ff_ff p) 1" unfolding eq_dff_def by auto
        moreover have " q. divides_ff 1 (content_ff_ff q)" using content_ff_map_poly_to_fract
          unfolding divides_ff_def by auto
        from divides_ff_trans[OF ct this] have ct: " q. divides_ff (content_ff_ff p) (content_ff_ff q)" .
        with dvd_E show ?thesis using dvd_PM_iff by blast
      next
        assume "degree p = 0  irred (coeff p 0)"
        hence deg: "degree p = 0" and irr: "irred (coeff p 0)" by auto
        from degree0_coeffs[OF deg] p obtain a where p: "p = [:a:]" and a: "a  0" by auto
        with irr have irr: "irred a" and aM: "a  carrier mk_monoid" by auto
        from M.irreducible_prime[OF irr aM] have prime: "Divisibility.prime mk_monoid a" .
        from content_ff_map_poly_to_fract obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
        from content_ff_map_poly_to_fract obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
        from content_ff_map_poly_to_fract obtain cr where cr: "content_ff_ff r = to_fract cr" by auto
        have "divides_ff (to_fract a) (content_ff_ff p)" unfolding p content_ff_iff using a by auto
        from divides_ff_trans[OF this[unfolded cp] dvd_ct[unfolded cp cq cr]]
        have "divides_ff (to_fract a) (to_fract (cq * cr))" by simp
        hence dvd: "a dvd cq * cr" by (auto simp add: divides_ff_def simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
        from content_ff_divides_ff[of "to_fract a" "?E p"] have "divides_ff (to_fract cp) (to_fract a)"
          using cp a p by auto
        hence cpa: "cp dvd a" by simp
        from a q r cq cr have aM: "a  carrier mk_monoid" and qM: "cq  carrier mk_monoid" and rM: "cr  carrier mk_monoid"
          and q': "cq  0" and r': "cr  0" and qr': "cq * cr  0" 
          by auto
        from M.prime_divides[OF qM rM prime] q' r' qr' dvd
        have "a dvd cq  a dvd cr" by simp
        with dvd_trans[OF cpa] have dvd: "cp dvd cq  cp dvd cr" by auto
        have " q. ?E p * (smult (inverse (to_fract a)) q) = q" unfolding p using a by (auto simp: one_poly_def)
        hence Edvd: " q. ?E p dvd q" unfolding dvd_def by metis
        from dvd Edvd show ?thesis apply (subst(1 2) dvd_PM_iff) unfolding cp cq cr by auto
      qed
      thus "factor p q  factor p r" unfolding factor_idom using p q r by auto
    qed
  qed
qed

instance poly :: (ufd) ufd
  by (intro class.ufd.of_class.intro factorial_monoid_imp_ufd factorial_monoid_poly)


lemma primitive_iff_some_content_dvd_1:
  fixes f :: "'a :: ufd poly" (* gcd_condition suffices... *)
  shows "primitive f  some_gcd.listgcd (coeffs f) dvd 1" (is "_  ?c dvd 1")
proof(intro iffI primitiveI)
  fix x
  assume "(y. y  set (coeffs f)  x dvd y)"
  from some_gcd.listgcd_greatest[of "coeffs f", OF this]
  have "x dvd ?c" by simp
  also assume "?c dvd 1"
  finally show "x dvd 1".
next
  assume "primitive f"
  from primitiveD[OF this some_gcd.listgcd[of _ "coeffs f"]]
  show "?c dvd 1" by auto
qed

end

Theory Poly_Mod

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹Polynomials in Rings and Fields›

subsection ‹Polynomials in Rings›

text ‹We use a locale to work with polynomials in some integer-modulo ring.›

theory Poly_Mod
  imports
  "HOL-Computational_Algebra.Primes"
  Polynomial_Factorization.Square_Free_Factorization
  Unique_Factorization_Poly
begin

locale poly_mod = fixes m :: "int" 
begin

definition M :: "int  int" where "M x = x mod m" 

lemma M_0[simp]: "M 0 = 0"
  by (auto simp add: M_def)

lemma M_M[simp]: "M (M x) = M x"
  by (auto simp add: M_def)

lemma M_plus[simp]: "M (M x + y) = M (x + y)" "M (x + M y) = M (x + y)"
  by (auto simp add: M_def mod_simps)
  
lemma M_minus[simp]: "M (M x - y) = M (x - y)" "M (x - M y) = M (x - y)" 
  by (auto simp add: M_def mod_simps)

lemma M_times[simp]: "M (M x * y) = M (x * y)" "M (x * M y) = M (x * y)"
  by (auto simp add: M_def mod_simps)

lemma M_sum: "M (sum (λ x. M (f x)) A) = M (sum f A)"
proof (induct A rule: infinite_finite_induct) 
  case (insert x A)
  from insert(1-2) have "M (xinsert x A. M (f x)) = M (f x + M ((xA. M (f x))))" by simp
  also have "M ((xA. M (f x))) = M ((xA. f x))" using insert by simp
  finally show ?case using insert by simp
qed auto

definition inv_M :: "int  int" where
  "inv_M = (λ x. if x + x  m then x else x - m)" 

lemma M_inv_M_id[simp]: "M (inv_M x) = M x" 
  unfolding inv_M_def M_def by simp


definition Mp :: "int poly  int poly" where "Mp = map_poly M"

lemma Mp_0[simp]: "Mp 0 = 0" unfolding Mp_def by auto

lemma Mp_coeff: "coeff (Mp f) i = M (coeff f i)" unfolding Mp_def 
  by (simp add: M_def coeff_map_poly) 

abbreviation eq_m :: "int poly  int poly  bool" (infixl "=m" 50) where
  "f =m g  (Mp f = Mp g)"

notation eq_m (infixl "=m" 50)

abbreviation degree_m :: "int poly  nat" where 
  "degree_m f  degree (Mp f)" 

lemma mult_Mp[simp]: "Mp (Mp f * g) = Mp (f * g)" "Mp (f * Mp g) = Mp (f * g)" 
proof -
  {
    fix f g
    have "Mp (Mp f * g) = Mp (f * g)" 
    unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff
    proof 
      fix n
      show "M (in. M (coeff f i) * coeff g (n - i)) = M (in. coeff f i * coeff g (n - i))"
        by (subst M_sum[symmetric], rule sym, subst M_sum[symmetric], unfold M_times, simp)
    qed
  }
  from this[of f g] this[of g f] show "Mp (Mp f * g) = Mp (f * g)" "Mp (f * Mp g) = Mp (f * g)"
    by (auto simp: ac_simps)
qed

lemma plus_Mp[simp]: "Mp (Mp f + g) = Mp (f + g)" "Mp (f + Mp g) = Mp (f + g)" 
  unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff by (auto simp add: Mp_coeff)

lemma minus_Mp[simp]: "Mp (Mp f - g) = Mp (f - g)" "Mp (f - Mp g) = Mp (f - g)" 
  unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff by (auto simp add: Mp_coeff)    

lemma Mp_smult[simp]: "Mp (smult (M a) f) = Mp (smult a f)" "Mp (smult a (Mp f)) = Mp (smult a f)" 
  unfolding Mp_def smult_as_map_poly
  by (rule poly_eqI, auto simp: coeff_map_poly)+

lemma Mp_Mp[simp]: "Mp (Mp f) = Mp f" unfolding Mp_def
  by (intro poly_eqI, auto simp: coeff_map_poly)

lemma Mp_smult_m_0[simp]: "Mp (smult m f) = 0" 
  by (intro poly_eqI, auto simp: Mp_coeff, auto simp: M_def)

definition dvdm :: "int poly  int poly  bool" (infix "dvdm" 50) where
  "f dvdm g = ( h. g =m f * h)"
notation dvdm (infix "dvdm" 50)


lemma dvdmE:
  assumes fg: "f dvdm g"
    and main: "h. g =m f * h  Mp h = h  thesis"
  shows "thesis"
proof-
  from fg obtain h where "g =m f * h" by (auto simp: dvdm_def)
  then have "g =m f * Mp h" by auto
  from main[OF this] show thesis by auto
qed

lemma Mp_dvdm[simp]: "Mp f dvdm g  f dvdm g"
  and dvdm_Mp[simp]: "f dvdm Mp g  f dvdm g" by (auto simp: dvdm_def)

definition irreducible_m
  where "irreducible_m f = (¬f =m 0  ¬ f dvdm 1  (a b. f =m a * b  a dvdm 1  b dvdm 1))"

definition irreducibled_m :: "int poly  bool" where "irreducibled_m f 
   degree_m f > 0 
   ( g h. degree_m g < degree_m f  degree_m h < degree_m f  ¬ f =m g * h)"

definition prime_elem_m
  where "prime_elem_m f  ¬ f =m 0  ¬ f dvdm 1  (g h. f dvdm g * h  f dvdm g  f dvdm h)"

lemma degree_m_le_degree [intro!]: "degree_m f  degree f"
  by (simp add: Mp_def degree_map_poly_le)

lemma irreducibled_mI:
  assumes f0: "degree_m f > 0"
      and main: "g h. Mp g = g  Mp h = h  degree g > 0  degree g < degree_m f  degree h > 0  degree h < degree_m f  f =m g * h  False"
    shows "irreducibled_m f"
proof (unfold irreducibled_m_def, intro conjI allI impI f0 notI)
  fix g h
  assume deg: "degree_m g < degree_m f" "degree_m h < degree_m f" and "f =m g * h"
  then have f: "f =m Mp g * Mp h" by simp
  have "degree_m f  degree_m g + degree_m h"
    unfolding f using degree_mult_le order.trans by blast
  with main[of "Mp g" "Mp h"] deg f show False by auto
qed

lemma irreducibled_mE:
  assumes "irreducibled_m f"
    and "degree_m f > 0  (g h. degree_m g < degree_m f  degree_m h < degree_m f  ¬ f =m g * h)  thesis"
  shows thesis
  using assms by (unfold irreducibled_m_def, auto)

lemma irreducibled_mD:
  assumes "irreducibled_m f"
  shows "degree_m f > 0" and "g h. degree_m g < degree_m f  degree_m h < degree_m f  ¬ f =m g * h"
  using assms by (auto elim: irreducibled_mE)

definition square_free_m :: "int poly  bool" where 
  "square_free_m f = (¬ f =m 0  ( g. degree_m g  0  ¬ (g * g dvdm f)))"

definition coprime_m :: "int poly  int poly  bool" where 
  "coprime_m f g = ( h. h dvdm f  h dvdm g  h dvdm 1)"

lemma Mp_square_free_m[simp]: "square_free_m (Mp f) = square_free_m f" 
  unfolding square_free_m_def dvdm_def by simp

lemma square_free_m_cong: "square_free_m f  Mp f = Mp g  square_free_m g" 
  unfolding square_free_m_def dvdm_def by simp

lemma Mp_prod_mset[simp]: "Mp (prod_mset (image_mset Mp b)) = Mp (prod_mset b)" 
proof (induct b)
  case (add x b)
  have "Mp (prod_mset (image_mset Mp ({#x#}+b))) = Mp (Mp x * prod_mset (image_mset Mp b))" by simp
  also have " = Mp (Mp x * Mp (prod_mset (image_mset Mp b)))" by simp
  also have " = Mp ( Mp x * Mp (prod_mset b))" unfolding add by simp
  finally show ?case by simp
qed simp

lemma Mp_prod_list: "Mp (prod_list (map Mp b)) = Mp (prod_list b)" 
proof (induct b)
  case (Cons b xs)
  have "Mp (prod_list (map Mp (b # xs))) = Mp (Mp b * prod_list (map Mp xs))" by simp
  also have " = Mp (Mp b * Mp (prod_list (map Mp xs)))" by simp
  also have " = Mp (Mp b * Mp (prod_list xs))" unfolding Cons by simp
  finally show ?case by simp
qed simp

text ‹Polynomial evaluation modulo›
definition "M_poly p x  M (poly p x)"

lemma M_poly_Mp[simp]: "M_poly (Mp p) = M_poly p"
proof(intro ext, induct p)
  case 0 show ?case by auto
next
  case IH: (pCons a p)
  from IH(1) have "M_poly (Mp (pCons a p)) x = M (a + M(x * M_poly (Mp p) x))"
    by (simp add: M_poly_def Mp_def)
  also note IH(2)[of x]
  finally show ?case by (simp add: M_poly_def)
qed

lemma Mp_lift_modulus: assumes "f =m g" 
  shows "poly_mod.eq_m (m * k) (smult k f) (smult k g)" 
  using assms unfolding poly_eq_iff poly_mod.Mp_coeff coeff_smult
  unfolding poly_mod.M_def by simp

lemma Mp_ident_product: "n > 0  Mp f = f  poly_mod.Mp (m * n) f = f"
  unfolding poly_eq_iff poly_mod.Mp_coeff poly_mod.M_def 
  by (auto simp add: zmod_zmult2_eq) (metis mod_div_trivial mod_0)

lemma Mp_shrink_modulus: assumes "poly_mod.eq_m (m * k) f g" "k  0" 
  shows "f =m g" 
proof -
  from assms have a: " n. coeff f n mod (m * k) = coeff g n mod (m * k)"
    unfolding poly_eq_iff poly_mod.Mp_coeff unfolding poly_mod.M_def by auto
  show ?thesis unfolding poly_eq_iff poly_mod.Mp_coeff unfolding poly_mod.M_def
  proof
    fix n
    show "coeff f n mod m = coeff g n mod m" using a[of n] k  0 
      by (metis mod_mult_right_eq mult.commute mult_cancel_left mult_mod_right)
  qed
qed  
  

lemma degree_m_le: "degree_m f  degree f" unfolding Mp_def by (rule degree_map_poly_le)

lemma degree_m_eq: "coeff f (degree f) mod m  0  m > 1  degree_m f = degree f" 
  using degree_m_le[of f] unfolding Mp_def
  by (auto intro: degree_map_poly simp: Mp_def poly_mod.M_def)

lemma degree_m_mult_le:  
  assumes eq: "f =m g * h" 
  shows "degree_m f  degree_m g + degree_m h" 
proof -
  have "degree_m f = degree_m (Mp g * Mp h)" using eq by simp
  also have "  degree (Mp g * Mp h)" by (rule degree_m_le)
  also have "  degree_m g + degree_m h" by (rule degree_mult_le)
  finally show ?thesis by auto
qed

lemma degree_m_smult_le: "degree_m (smult c f)  degree_m f"
  by (metis Mp_0 coeff_0 degree_le degree_m_le degree_smult_eq poly_mod.Mp_smult(2) smult_eq_0_iff)

lemma irreducible_m_Mp[simp]: "irreducible_m (Mp f)  irreducible_m f" by (simp add: irreducible_m_def)

lemma eq_m_irreducible_m: "f =m g  irreducible_m f  irreducible_m g"
  using irreducible_m_Mp by metis

definition mset_factors_m where "mset_factors_m F p 
  F  {#}  (f. f ∈# F  irreducible_m f)  p =m prod_mset F"

end

declare poly_mod.M_def[code]
declare poly_mod.Mp_def[code]
declare poly_mod.inv_M_def[code]

definition Irr_Mon :: "'a :: comm_semiring_1 poly set"
  where "Irr_Mon = {x. irreducible x  monic x}" 

definition factorization :: "'a :: comm_semiring_1 poly set  'a poly  ('a × 'a poly multiset)  bool" where
  "factorization Factors f cfs  (case cfs of (c,fs)  f = (smult c (prod_mset fs))  (set_mset fs  Factors))" 

definition unique_factorization :: "'a :: comm_semiring_1 poly set  'a poly  ('a × 'a poly multiset)  bool" where
  "unique_factorization Factors f cfs = (Collect (factorization Factors f) = {cfs})" 

lemma irreducible_multD:
  assumes l: "irreducible (a*b)"
  shows "a dvd 1  irreducible b  b dvd 1  irreducible a"
proof-
  from l have "a dvd 1  b dvd 1" by auto
  then show ?thesis
  proof(elim disjE)
    assume a: "a dvd 1"
    with l have "irreducible b"
      unfolding irreducible_def
      by (meson is_unit_mult_iff mult.left_commute mult_not_zero)
    with a show ?thesis by auto
  next
    assume a: "b dvd 1"
    with l have "irreducible a"
      unfolding irreducible_def
      by (meson is_unit_mult_iff mult_not_zero semiring_normalization_rules(16))
    with a show ?thesis by auto
  qed
qed

lemma irreducible_dvd_prod_mset:
  fixes p :: "'a :: field poly"
  assumes irr: "irreducible p" and dvd: "p dvd prod_mset as"
  shows " a ∈# as. p dvd a"
proof -
  from irr[unfolded irreducible_def] have deg: "degree p  0" by auto
  hence p1: "¬ p dvd 1" unfolding dvd_def
    by (metis degree_1 nonzero_mult_div_cancel_left div_poly_less linorder_neqE_nat mult_not_zero not_less0 zero_neq_one)
  from dvd show ?thesis
  proof (induct as)
    case (add a as)
    hence "prod_mset (add_mset a as) = a * prod_mset as" by auto
    from add(2)[unfolded this] add(1) irr
    show ?case by auto
  qed (insert p1, auto)
qed

lemma monic_factorization_unique_mset:
  fixes P::"'a::field poly multiset"
  assumes eq: "prod_mset P = prod_mset Q" 
    and P: "set_mset P  {q. irreducible q  monic q}"
    and Q: "set_mset Q  {q. irreducible q  monic q}"
  shows "P = Q" 
proof -
  {
    fix P Q :: "'a poly multiset"
    assume id: "prod_mset P = prod_mset Q" 
    and P: "set_mset P  {q. irreducible q  monic q}"
    and Q: "set_mset Q  {q. irreducible q  monic q}"
    hence "P ⊆# Q"
    proof (induct P arbitrary: Q)
      case (add x P Q')
      from add(3) have irr: "irreducible x" and mon: "monic x" by auto
      have " a ∈# Q'. x dvd a"
      proof (rule irreducible_dvd_prod_mset[OF irr])
        show "x dvd prod_mset Q'" unfolding add(2)[symmetric] by simp
      qed
      then obtain y Q where Q': "Q' = add_mset y Q" and xy: "x dvd y" by (meson mset_add)
      from add(4) Q' have irr': "irreducible y" and mon': "monic y" by auto
      have "x = y"  using irr irr' xy mon mon'
        by (metis irreducibleD' irreducible_not_unit poly_dvd_antisym)
      hence Q': "Q' = Q + {#x#}" using Q' by auto
      from mon have x0: "x  0" by auto
      from arg_cong[OF add(2)[unfolded Q'], of "λ z. z div x"] 
      have eq: "prod_mset P = prod_mset Q" using x0 by auto
      from add(3-4)[unfolded Q'] 
      have "set_mset P  {q. irreducible q  monic q}" "set_mset Q  {q. irreducible q  monic q}" 
        by auto
      from add(1)[OF eq this] show ?case unfolding Q' by auto
    qed auto
  }
  from this[OF eq P Q] this[OF eq[symmetric] Q P]
  show ?thesis by auto
qed


lemma exactly_one_monic_factorization:
  assumes mon: "monic (f :: 'a :: field poly)"
  shows "∃! fs. f = prod_mset fs  set_mset fs  {q. irreducible q  monic q}"
proof -
  from monic_irreducible_factorization[OF mon]
  obtain gs g where fin: "finite gs" and f: "f = (ags. a ^ Suc (g a))" 
    and gs: "gs  {q. irreducible q  monic q}" 
    by blast
  from fin 
  have " fs. set_mset fs  gs  prod_mset fs = (ags. a ^ Suc (g a))" 
  proof (induct gs)
    case (insert a gs)
    from insert(3) obtain fs where *: "set_mset fs  gs" "prod_mset fs = (ags. a ^ Suc (g a))" by auto    
    let ?fs = "fs + replicate_mset (Suc (g a)) a" 
    show ?case 
    proof (rule exI[of _ "fs + replicate_mset (Suc (g a)) a"], intro conjI)
      show "set_mset ?fs  insert a gs" using *(1) by auto
      show "prod_mset ?fs = (ainsert a gs. a ^ Suc (g a))" 
        by (subst prod.insert[OF insert(1-2)], auto simp: *(2))
    qed
  qed simp
  then obtain fs where "set_mset fs  gs" "prod_mset fs = (ags. a ^ Suc (g a))" by auto
  with gs f have ex: "fs. f = prod_mset fs  set_mset fs  {q. irreducible q  monic q}"
    by (intro exI[of _ fs], auto)
  thus ?thesis using monic_factorization_unique_mset by blast
qed

lemma monic_prod_mset:
  fixes as :: "'a :: idom poly multiset"
  assumes " a. a  set_mset as  monic a"
  shows "monic (prod_mset as)" using assms
  by (induct as, auto intro: monic_mult)

lemma exactly_one_factorization:
  assumes f: "f  (0 :: 'a :: field poly)"
  shows "∃! cfs. factorization Irr_Mon f cfs"
proof -
  let ?a = "coeff f (degree f)" 
  let ?b = "inverse ?a" 
  let ?g = "smult ?b f" 
  define g where "g = ?g"
  from f have a: "?a  0" "?b  0" by (auto simp: field_simps)
  hence "monic g" unfolding g_def by simp
  note ex1 = exactly_one_monic_factorization[OF this, folded Irr_Mon_def]
  then obtain fs where g: "g = prod_mset fs" "set_mset fs  Irr_Mon" by auto
  let ?cfs = "(?a,fs)" 
  have cfs: "factorization Irr_Mon f ?cfs" unfolding factorization_def split g(1)[symmetric]
    using g(2) unfolding g_def by (simp add: a field_simps)
  show ?thesis
  proof (rule, rule cfs)
    fix dgs
    assume fact: "factorization Irr_Mon f dgs" 
    obtain d gs where dgs: "dgs = (d,gs)" by force
    from fact[unfolded factorization_def dgs split]
    have fd: "f = smult d (prod_mset gs)" and gs: "set_mset gs  Irr_Mon" by auto
    have "monic (prod_mset gs)" by (rule monic_prod_mset, insert gs[unfolded Irr_Mon_def], auto)
    hence d: "d = ?a" unfolding fd by auto
    from arg_cong[OF fd, of "λ x. smult ?b x", unfolded d g_def[symmetric]]
    have "g = prod_mset gs" using a by (simp add: field_simps)
    with ex1 g gs have "gs = fs" by auto
    thus "dgs = ?cfs" unfolding dgs d by auto
  qed
qed

lemma mod_ident_iff: "m > 0  (x :: int) mod m = x  x  {0 ..< m}"
  by (metis Divides.pos_mod_bound Divides.pos_mod_sign atLeastLessThan_iff mod_pos_pos_trivial)

declare prod_mset_prod_list[simp]

lemma mult_1_is_id[simp]: "(*) (1 :: 'a :: ring_1) = id" by auto

context poly_mod
begin

lemma degree_m_eq_monic: "monic f  m > 1  degree_m f = degree f" 
  by (rule degree_m_eq) auto

lemma monic_degree_m_lift: assumes "monic f" "k > 1" "m > 1"
  shows "monic (poly_mod.Mp (m * k) f)" 
proof -
  have deg: "degree (poly_mod.Mp (m * k) f) = degree f" 
    by (rule poly_mod.degree_m_eq_monic[of f "m * k"], insert assms, auto simp: less_1_mult)
  show ?thesis unfolding poly_mod.Mp_coeff deg assms poly_mod.M_def using assms(2-)
    by (simp add: less_1_mult)
qed

end


locale poly_mod_2 = poly_mod m for m +
  assumes m1: "m > 1"
begin

lemma M_1[simp]: "M 1 = 1" unfolding M_def using m1
  by auto

lemma Mp_1[simp]: "Mp 1 = 1" unfolding Mp_def by simp

lemma monic_degree_m[simp]: "monic f  degree_m f = degree f" 
  using degree_m_eq_monic[of f] using m1 by auto

lemma monic_Mp: "monic f  monic (Mp f)" 
  by (auto simp: Mp_coeff)

lemma Mp_0_smult_sdiv_poly: assumes "Mp f = 0" 
  shows "smult m (sdiv_poly f m) = f"
proof (intro poly_eqI, unfold Mp_coeff coeff_smult sdiv_poly_def, subst coeff_map_poly, force)
  fix n
  from assms have "coeff (Mp f) n = 0" by simp
  hence 0: "coeff f n mod m = 0" unfolding Mp_coeff M_def .
  thus "m * (coeff f n div m) = coeff f n" by auto
qed

lemma Mp_product_modulus: "m' = m * k  k > 0  Mp (poly_mod.Mp m' f) = Mp f" 
  by (intro poly_eqI, unfold poly_mod.Mp_coeff poly_mod.M_def, auto simp: mod_mod_cancel) 

lemma inv_M_rev: assumes bnd: "2 * abs c < m" 
  shows "inv_M (M c) = c"
proof (cases "c  0")
  case True
  with bnd show ?thesis unfolding M_def inv_M_def by auto
next
  case False
  have 2: " v :: int. 2 * v = v + v" by auto
  from False have c: "c < 0" by auto
  from bnd c have "c + m > 0" "c + m < m" by auto
  with c have cm: "c mod m = c + m"
    by (metis le_less mod_add_self2 mod_pos_pos_trivial)
  from c bnd have "2 * (c mod m) > m" unfolding cm by auto
  with bnd c show ?thesis unfolding M_def inv_M_def cm by auto
qed

end

lemma (in poly_mod) degree_m_eq_prime:
  assumes f0: "Mp f  0"
  and deg: "degree_m f = degree f" 
  and eq: "f =m g * h" 
  and p: "prime m" 
  shows "degree_m f = degree_m g + degree_m h" 
proof -
  interpret poly_mod_2 m using prime_ge_2_int[OF p] unfolding poly_mod_2_def by simp
  from f0 eq have "Mp (Mp g * Mp h)  0" by auto
  hence "Mp g * Mp h  0" using Mp_0 by (cases "Mp g * Mp h", auto)
  hence g0: "Mp g  0" and h0: "Mp h  0" by auto
  have "degree (Mp (g * h)) = degree_m (Mp g * Mp h)" by simp
  also have " = degree (Mp g * Mp h)" 
  proof (rule degree_m_eq[OF _ m1], rule)
    have id: " g. coeff (Mp g) (degree (Mp g)) mod m = coeff (Mp g) (degree (Mp g))" 
      unfolding M_def[symmetric] Mp_coeff by simp
    from p have p': "prime m" unfolding prime_int_nat_transfer unfolding prime_nat_iff by auto 
    assume "coeff (Mp g * Mp h) (degree (Mp g * Mp h)) mod m = 0" 
    from this[unfolded coeff_degree_mult] 
    have "coeff (Mp g) (degree (Mp g)) mod m = 0  coeff (Mp h) (degree (Mp h)) mod m = 0"
      unfolding dvd_eq_mod_eq_0[symmetric] using m1 prime_dvd_mult_int[OF p'] by auto    
    with g0 h0 show False unfolding id by auto
  qed
  also have " = degree (Mp g) + degree (Mp h)" 
    by (rule degree_mult_eq[OF g0 h0])
  finally show ?thesis using eq by simp
qed 

lemma monic_smult_add_small: assumes "f = 0  degree f < degree g" and mon: "monic g" 
  shows "monic (g + smult q f)"
proof (cases "f = 0")
  case True
  thus ?thesis using mon by auto
next
  case False
  with assms have "degree f < degree g" by auto
  hence "degree (smult q f) < degree g" by (meson degree_smult_le not_less order_trans)
  thus ?thesis using mon using coeff_eq_0 degree_add_eq_left by fastforce
qed

context poly_mod 
begin

definition factorization_m :: "int poly  (int × int poly multiset)  bool" where
  "factorization_m f cfs  (case cfs of (c,fs)  f =m (smult c (prod_mset fs))  
    ( f  set_mset fs. irreducibled_m f  monic (Mp f)))"

definition Mf :: "int × int poly multiset  int × int poly multiset" where
  "Mf cfs  case cfs of (c,fs)  (M c, image_mset Mp fs)" 

lemma Mf_Mf[simp]: "Mf (Mf x) = Mf x" 
proof (cases x, auto simp: Mf_def, goal_cases)
  case (1 c fs)
  show ?case by (induct fs, auto)
qed

definition equivalent_fact_m :: "int × int poly multiset  int × int poly multiset  bool" where
  "equivalent_fact_m cfs dgs = (Mf cfs = Mf dgs)" 

definition unique_factorization_m :: "int poly  (int × int poly multiset)  bool" where
  "unique_factorization_m f cfs = (Mf ` Collect (factorization_m f) = {Mf cfs})"

lemma Mp_irreducibled_m[simp]: "irreducibled_m (Mp f) = irreducibled_m f" 
  unfolding irreducibled_m_def dvdm_def by simp

lemma Mf_factorization_m[simp]: "factorization_m f (Mf cfs) = factorization_m f cfs" 
  unfolding factorization_m_def Mf_def
proof (cases cfs, simp, goal_cases)
  case (1 c fs)
  have "Mp (smult c (prod_mset fs)) = Mp (smult (M c) (Mp (prod_mset fs)))" by simp
  also have " = Mp (smult (M c) (Mp (prod_mset (image_mset Mp fs))))"
    unfolding Mp_prod_mset by simp
  also have " = Mp (smult (M c) (prod_mset (image_mset Mp fs)))" unfolding Mp_smult ..
  finally show ?case by auto
qed    

lemma unique_factorization_m_imp_factorization: assumes "unique_factorization_m f cfs" 
  shows "factorization_m f cfs" 
proof -
  from assms[unfolded unique_factorization_m_def] obtain dfs where
     fact: "factorization_m f dfs" and id: "Mf cfs = Mf dfs" by blast
  from fact have "factorization_m f (Mf dfs)" by simp
  from this[folded id] show ?thesis by simp
qed

lemma unique_factorization_m_alt_def: "unique_factorization_m f cfs = (factorization_m f cfs
   ( dgs. factorization_m f dgs  Mf dgs = Mf cfs))" 
  using unique_factorization_m_imp_factorization[of f cfs]
  unfolding unique_factorization_m_def by auto

end

context poly_mod_2
begin

lemma factorization_m_lead_coeff: assumes "factorization_m f (c,fs)" 
  shows "lead_coeff (Mp f) = M c" 
proof -
  note * = assms[unfolded factorization_m_def split]
  have "monic (prod_mset (image_mset Mp fs))" by (rule monic_prod_mset, insert *, auto)
  hence "monic (Mp (prod_mset (image_mset Mp fs)))" by (rule monic_Mp)
  from this[unfolded Mp_prod_mset] have monic: "monic (Mp (prod_mset fs))" by simp
  from * have "lead_coeff (Mp f) = lead_coeff (Mp (smult c (prod_mset fs)))" by simp
  also have "Mp (smult c (prod_mset fs)) = Mp (smult (M c) (Mp (prod_mset fs)))" by simp
  finally show ?thesis 
    using monic ‹smult c (prod_mset fs) =m smult (M c) (Mp (prod_mset fs))
    by (metis M_M M_def Mp_0 Mp_coeff lead_coeff_smult m1 mult_cancel_left2 poly_mod.degree_m_eq smult_eq_0_iff)
qed

lemma factorization_m_smult: assumes "factorization_m f (c,fs)" 
  shows "factorization_m (smult d f) (c * d,fs)"
proof -
  note * = assms[unfolded factorization_m_def split]
  from * have f: "Mp f = Mp (smult c (prod_mset fs))" by simp
  have "Mp (smult d f) = Mp (smult d (Mp f))" by simp
  also have " = Mp (smult (c * d) (prod_mset fs))" unfolding f by (simp add: ac_simps)
  finally show ?thesis using assms
  unfolding factorization_m_def split by auto
qed

lemma factorization_m_prod: assumes "factorization_m f (c,fs)" "factorization_m g (d,gs)" 
  shows "factorization_m (f * g) (c * d, fs + gs)"
proof -
  note * = assms[unfolded factorization_m_def split]
  have "Mp (f * g) = Mp (Mp f * Mp g)" by simp
  also have "Mp f = Mp (smult c (prod_mset fs))" using * by simp
  also have "Mp g = Mp (smult d (prod_mset gs))" using * by simp
  finally have "Mp (f * g) = Mp (smult (c * d) (prod_mset (fs + gs)))" unfolding mult_Mp
    by (simp add: ac_simps)
  with * show ?thesis unfolding factorization_m_def split by auto
qed

lemma Mp_factorization_m[simp]: "factorization_m (Mp f) cfs = factorization_m f cfs" 
  unfolding factorization_m_def by simp

lemma Mp_unique_factorization_m[simp]: 
  "unique_factorization_m (Mp f) cfs = unique_factorization_m f cfs" 
  unfolding unique_factorization_m_alt_def by simp

lemma unique_factorization_m_cong: "unique_factorization_m f cfs  Mp f = Mp g 
   unique_factorization_m g cfs"
  unfolding Mp_unique_factorization_m[of f, symmetric] by simp

lemma unique_factorization_mI: assumes "factorization_m f (c,fs)" 
  and " d gs. factorization_m f (d,gs)  Mf (d,gs) = Mf (c,fs)"
  shows "unique_factorization_m f (c,fs)" 
  unfolding unique_factorization_m_alt_def 
    by (intro conjI[OF assms(1)] allI impI, insert assms(2), auto)

lemma unique_factorization_m_smult: assumes uf: "unique_factorization_m f (c,fs)"
  and d: "M (di * d) = 1"
  shows "unique_factorization_m (smult d f) (c * d,fs)"
proof (rule unique_factorization_mI[OF factorization_m_smult])
  show "factorization_m f (c, fs)" using uf[unfolded unique_factorization_m_alt_def] by auto
  fix e gs
  assume fact: "factorization_m (smult d f) (e,gs)" 
  from factorization_m_smult[OF this, of di] 
  have "factorization_m (Mp (smult di (smult d f))) (e * di, gs)" by simp
  also have "Mp (smult di (smult d f)) = Mp (smult (M (di * d)) f)" by simp
  also have " = Mp f" unfolding d by simp
  finally have fact: "factorization_m f (e * di, gs)" by simp
  with uf[unfolded unique_factorization_m_alt_def] have eq: "Mf (e * di, gs) = Mf (c, fs)" by blast
  from eq[unfolded Mf_def] have "M (e * di) = M c" by simp
  from arg_cong[OF this, of "λ x. M (x * d)"]
  have "M (e * M (di * d)) = M (c * d)" by (simp add: ac_simps)
  from this[unfolded d] have e: "M e = M (c * d)" by simp
  with eq
  show "Mf (e,gs) = Mf (c * d, fs)" unfolding Mf_def split by simp
qed  

lemma unique_factorization_m_smultD: assumes uf: "unique_factorization_m (smult d f) (c,fs)"
  and d: "M (di * d) = 1"
  shows "unique_factorization_m f (c * di,fs)"
proof -
  from d have d': "M (d * di) = 1" by (simp add: ac_simps)
  show ?thesis
  proof (rule unique_factorization_m_cong[OF unique_factorization_m_smult[OF uf d']], 
    rule poly_eqI, unfold Mp_coeff coeff_smult)
    fix n
    have "M (di * (d * coeff f n)) = M (M (di * d) * coeff f n)" by (auto simp: ac_simps)
    from this[unfolded d] show "M (di * (d * coeff f n)) = M (coeff f n)" by simp
  qed
qed

lemma degree_m_eq_lead_coeff: "degree_m f = degree f  lead_coeff (Mp f) = M (lead_coeff f)"
  by (simp add: Mp_coeff)

lemma unique_factorization_m_zero: assumes "unique_factorization_m f (c,fs)" 
  shows "M c  0" 
proof
  assume c: "M c = 0" 
  from unique_factorization_m_imp_factorization[OF assms]
  have "Mp f = Mp (smult (M c) (prod_mset fs))" unfolding factorization_m_def split 
    by simp
  from this[unfolded c] have f: "Mp f = 0" by simp
  have "factorization_m f (0,{#})" 
    unfolding factorization_m_def split f by auto
  moreover have "Mf (0,{#}) = (0,{#})" unfolding Mf_def by auto
  ultimately have fact1: "(0, {#})  Mf ` Collect (factorization_m f)" by force
  define g :: "int poly" where "g = [:0,1:]" 
  have mpg: "Mp g = [:0,1:]" unfolding Mp_def
    by (auto simp: g_def)
  {
    fix g h
    assume *: "degree (Mp g) = 0" "degree (Mp h) = 0" "[:0, 1:] = Mp (g * h)" 
    from arg_cong[OF *(3), of degree] have "1 = degree_m (Mp g * Mp h)" by simp
    also have "  degree (Mp g * Mp h)" by (rule degree_m_le)
    also have "  degree (Mp g) + degree (Mp h)" by (rule degree_mult_le)
    also have "  0" using * by simp
    finally have False by simp
  } note irr = this    
  have "factorization_m f (0,{# g #})" 
    unfolding factorization_m_def split using irr
    by (auto simp: irreducibled_m_def f mpg)
  moreover have "Mf (0,{# g #}) = (0,{# g #})" unfolding Mf_def by (auto simp: mpg, simp add: g_def)
  ultimately have fact2: "(0, {#g#})  Mf ` Collect (factorization_m f)" by force
  note [simp] = assms[unfolded unique_factorization_m_def]
  from fact1[simplified, folded fact2[simplified]] show False by auto
qed


end

context poly_mod
begin

lemma dvdm_smult: assumes "f dvdm g" 
  shows "f dvdm smult c g" 
proof -
  from assms[unfolded dvdm_def] obtain h where g: "g =m f * h" by auto
  show ?thesis unfolding dvdm_def
  proof (intro exI[of _ "smult c h"])
    have "Mp (smult c g) = Mp (smult c (Mp g))" by simp
    also have "Mp g = Mp (f * h)" using g by simp
    finally show "Mp (smult c g) = Mp (f * smult c h)" by simp
  qed
qed

lemma dvdm_factor: assumes "f dvdm g" 
  shows "f dvdm g * h" 
proof -
  from assms[unfolded dvdm_def] obtain k where g: "g =m f * k" by auto
  show ?thesis unfolding dvdm_def
  proof (intro exI[of _ "h * k"])
    have "Mp (g * h) = Mp (Mp g * h)" by simp
    also have "Mp g = Mp (f * k)" using g by simp
    finally show "Mp (g * h) = Mp (f * (h * k))" by (simp add: ac_simps)
  qed
qed    

lemma square_free_m_smultD: assumes "square_free_m (smult c f)" 
  shows "square_free_m f" 
  unfolding square_free_m_def
proof (intro conjI allI impI)
  fix g
  assume "degree_m g  0" 
  with assms[unfolded square_free_m_def] have "¬ g * g dvdm smult c f" by auto
  thus "¬ g * g dvdm f" using dvdm_smult[of "g * g" f c] by blast
next
  from assms[unfolded square_free_m_def] have "¬ smult c f =m 0" by simp
  thus "¬ f =m 0" 
    by (metis Mp_smult(2) smult_0_right)
qed

lemma square_free_m_smultI: assumes sf: "square_free_m f" 
  and inv: "M (ci * c) = 1" 
  shows "square_free_m (smult c f)" 
proof -
  have "square_free_m (smult ci (smult c f))" 
  proof (rule square_free_m_cong[OF sf], rule poly_eqI, unfold Mp_coeff coeff_smult)
    fix n
    have "M (ci * (c * coeff f n)) = M ( M (ci * c) * coeff f n)" by (simp add: ac_simps)
    from this[unfolded inv] show "M (coeff f n) = M (ci * (c * coeff f n))" by simp
  qed
  from square_free_m_smultD[OF this] show ?thesis .
qed


lemma square_free_m_factor: assumes "square_free_m (f * g)" 
  shows "square_free_m f" "square_free_m g"
proof -
  {
    fix f g
    assume sf: "square_free_m (f * g)" 
    have "square_free_m f"         
      unfolding square_free_m_def
    proof (intro conjI allI impI)
      fix h
      assume "degree_m h  0" 
      with sf[unfolded square_free_m_def] have "¬ h * h dvdm f * g" by auto
      thus "¬ h * h dvdm f" using dvdm_factor[of "h * h" f g] by blast
    next
      from sf[unfolded square_free_m_def] have "¬ f * g =m 0" by simp
      thus "¬ f =m 0"
        by (metis mult.commute mult_zero_right poly_mod.mult_Mp(2))
    qed
  }
  from this[of f g] this[of g f] assms 
  show "square_free_m f" "square_free_m g" by (auto simp: ac_simps)
qed

end

context poly_mod_2
begin

lemma Mp_ident_iff: "Mp f = f  ( n. coeff f n  {0 ..< m})" 
proof -
  have m0: "m > 0" using m1 by simp
  show ?thesis unfolding poly_eq_iff Mp_coeff M_def mod_ident_iff[OF m0] by simp
qed

lemma Mp_ident_iff': "Mp f = f  (set (coeffs f)  {0 ..< m})" 
proof -
  have 0: "0  {0 ..< m}" using m1 by auto
  have ran: "(n. coeff f n  {0..<m})  range (coeff f)  {0 ..< m}" by blast
  show ?thesis unfolding Mp_ident_iff ran using range_coeff[of f] 0 by auto
qed
end

lemma Mp_Mp_pow_is_Mp: "n  0  p > 1  poly_mod.Mp p (poly_mod.Mp (p^n) f) 
  = poly_mod.Mp p f"
  using  poly_mod_2.Mp_product_modulus poly_mod_2_def by(subst power_eq_if, auto)

lemma M_M_pow_is_M: "n  0  p > 1  poly_mod.M p (poly_mod.M (p^n) f) 
  = poly_mod.M p f" using Mp_Mp_pow_is_Mp[of n p "[:f:]"]
  by (metis coeff_pCons_0 poly_mod.Mp_coeff)

definition inverse_mod :: "int  int  int" where
  "inverse_mod x m = fst (bezout_coefficients x m)" 

lemma inverse_mod:
  "(inverse_mod x m * x) mod m = 1"
  if "coprime x m" "m > 1"
proof -
  from bezout_coefficients [of x m "inverse_mod x m" "snd (bezout_coefficients x m)"]
  have "inverse_mod x m * x + snd (bezout_coefficients x m) * m = gcd x m"
    by (simp add: inverse_mod_def)
  with that have "inverse_mod x m * x + snd (bezout_coefficients x m) * m = 1"
    by simp
  then have "(inverse_mod x m * x + snd (bezout_coefficients x m) * m) mod m = 1 mod m"
    by simp
  with m > 1 show ?thesis
    by simp
qed

lemma inverse_mod_pow:
  "(inverse_mod x (p ^ n) * x) mod (p ^ n) = 1"
  if "coprime x p" "p > 1" "n  0" 
  using that by (auto intro: inverse_mod)

lemma (in poly_mod) inverse_mod_coprime:
  assumes p: "prime m" 
  and cop: "coprime x m" shows "M (inverse_mod x m * x) = 1" 
  unfolding M_def using inverse_mod_pow[OF cop, of 1] p
  by (auto simp: prime_int_iff)

lemma (in poly_mod) inverse_mod_coprime_exp:
  assumes m: "m = p^n" and p: "prime p" 
  and n: "n  0" and cop: "coprime x p"
  shows "M (inverse_mod x m * x) = 1" 
  unfolding M_def unfolding m using inverse_mod_pow[OF cop _ n] p
  by (auto simp: prime_int_iff)

locale poly_mod_prime = poly_mod p for p :: int +
  assumes prime: "prime p" 
begin

sublocale poly_mod_2 p using prime unfolding poly_mod_2_def
  using prime_gt_1_int by force

lemma square_free_m_prod_imp_coprime_m: assumes sf: "square_free_m (A * B)" 
  shows "coprime_m A B"
  unfolding coprime_m_def
proof (intro allI impI)
  fix h
  assume dvd: "h dvdm A" "h dvdm B"
  then obtain ha hb where *: "Mp A = Mp (h * ha)" "Mp B = Mp (h * hb)" 
    unfolding dvdm_def by auto
  have AB: "Mp (A * B) = Mp (Mp A * Mp B)" by simp
  from this[unfolded *, simplified] 
  have eq: "Mp (A * B) = Mp (h * h * (ha * hb))" by (simp add: ac_simps)
  hence dvd_hh: "(h * h) dvdm (A * B)" unfolding dvdm_def by auto
  {
    assume "degree_m h  0" 
    from sf[unfolded square_free_m_def, THEN conjunct2, rule_format, OF this]
    have "¬ h * h dvdm A * B" . 
    with dvd_hh have False by simp
  }
  hence "degree (Mp h) = 0" by auto
  then obtain c where hc: "Mp h = [: c :]" by (rule degree_eq_zeroE)
  {
    assume "c = 0" 
    hence "Mp h = 0" unfolding hc by auto
    with *(1) have "Mp A = 0"
      by (metis Mp_0 mult_zero_left poly_mod.mult_Mp(1))
    with sf[unfolded square_free_m_def, THEN conjunct1] have False
      by (simp add: AB)
  }
  hence c0: "c  0" by auto    
  with arg_cong[OF hc[symmetric], of "λ f. coeff f 0", unfolded Mp_coeff M_def] m1
  have "c  0" "c < p" by auto
  with c0 have c_props:"c > 0" "c < p" by auto
  with prime have "prime p" by simp
  with c_props have "coprime p c"
    by (auto intro: prime_imp_coprime dest: zdvd_not_zless)
  then have "coprime c p"
    by (simp add: ac_simps)
  from inverse_mod_coprime[OF prime this]
  obtain d where d: "M (c * d) = 1" by (auto simp: ac_simps)
  show "h dvdm 1" unfolding dvdm_def
  proof (intro exI[of _ "[:d:]"])
    have "Mp (h * [: d :]) = Mp (Mp h * [: d :])" by simp
    also have " = Mp ([: c * d :])" unfolding hc by (auto simp: ac_simps)
    also have " = [: M (c * d) :]" unfolding Mp_def
      by (metis (no_types) M_0 map_poly_pCons Mp_0 Mp_def d zero_neq_one)
    also have " = 1" unfolding d by simp
    finally show "Mp 1 = Mp (h * [:d:])" by simp
  qed
qed

lemma coprime_exp_mod: "coprime lu p  n  0  lu mod p ^ n  0" 
  using prime by fastforce

end

context poly_mod
begin

definition Dp :: "int poly  int poly" where
  "Dp f = map_poly (λ a. a div m) f" 

lemma Dp_Mp_eq: "f = Mp f + smult m (Dp f)"
  by (rule poly_eqI, auto simp: Mp_coeff M_def Dp_def coeff_map_poly)

lemma dvd_imp_dvdm:
  assumes "a dvd b" shows "a dvdm b"
  by (metis assms dvd_def dvdm_def)

lemma dvdm_add:
  assumes a: "u dvdm a"
  and b: "u dvdm b"
  shows "u dvdm (a+b)"
proof -
  obtain a' where a: "a =m u*a'" using a unfolding dvdm_def by auto
  obtain b' where b: "b =m u*b'" using b unfolding dvdm_def by auto
  have "Mp (a + b) = Mp (u*a'+u*b')" using a b
    by (metis poly_mod.plus_Mp(1) poly_mod.plus_Mp(2))
  also have "... = Mp (u * (a'+ b'))"
    by (simp add: distrib_left)
  finally show ?thesis unfolding dvdm_def by auto
qed


lemma monic_dvdm_constant:
  assumes uk: "u dvdm [:k:]"
  and u1: "monic u" and u2: "degree u > 0" 
  shows "k mod m = 0"
proof -
  have d1: "degree_m [:k:] = degree [:k:]"    
    by (metis degree_pCons_0 le_zero_eq poly_mod.degree_m_le)
  obtain h where h: "Mp [:k:] = Mp (u * h)"
    using uk unfolding dvdm_def by auto
  have d2: "degree_m [:k:] = degree_m (u*h)" using h by metis
  have d3: "degree (map_poly M (u * map_poly M h)) = degree (u * map_poly M h)" 
    by (rule degree_map_poly)
       (metis coeff_degree_mult leading_coeff_0_iff mult.right_neutral M_M Mp_coeff Mp_def u1)
  thus ?thesis using assms d1 d2 d3
    by (auto, metis M_def map_poly_pCons degree_mult_right_le h leD map_poly_0 
        mult_poly_0_right pCons_eq_0_iff M_0 Mp_def mult_Mp(2)) 
qed

lemma div_mod_imp_dvdm:
  assumes "q r. b = q * a + Polynomial.smult m r"
  shows "a dvdm b"
proof -
  from assms  obtain q r where b:"b = a * q + smult m r"
    by (metis mult.commute)
  have a: "Mp (Polynomial.smult m r) = 0" by auto
  show ?thesis 
  proof (unfold dvdm_def, rule exI[of _ q])
    have "Mp (a * q + smult m r) = Mp (a * q + Mp (smult m r))" 
      using plus_Mp(2)[of "a*q" "smult m r"] by auto
    also have "... = Mp (a*q)" by auto
    finally show "eq_m b (a * q)" using b by auto
  qed
qed

lemma lead_coeff_monic_mult:
  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  assumes "monic p" shows "lead_coeff (p * q) = lead_coeff q"
  using assms by (simp add: lead_coeff_mult)

lemma degree_m_mult_eq:
  assumes p: "monic p" and q: "lead_coeff q mod m  0" and m1: "m > 1"
  shows "degree (Mp (p * q)) = degree p + degree q"
proof-
  have "lead_coeff (p * q) mod m  0"
    using q p by (auto simp: lead_coeff_monic_mult)
  with m1 show ?thesis
    by (auto simp: degree_m_eq intro!: degree_mult_eq)
qed

lemma dvdm_imp_degree_le:
  assumes pq: "p dvdm q" and p: "monic p" and q0: "Mp q  0" and m1: "m > 1"
  shows "degree p  degree q"
proof-
  from q0
  have q: "lead_coeff (Mp q) mod m  0"
    by (metis Mp_Mp Mp_coeff leading_coeff_neq_0 M_def)
  from pq obtain r where Mpq: "Mp q = Mp (p * Mp r)" by (auto elim: dvdmE)
  with p q have "lead_coeff (Mp r) mod m  0"
    by (metis Mp_Mp Mp_coeff leading_coeff_0_iff mult_poly_0_right M_def)
  from degree_m_mult_eq[OF p this m1] Mpq
  have "degree p  degree_m q" by simp
  thus ?thesis using degree_m_le le_trans by blast
qed

lemma dvdm_uminus [simp]:
  "p dvdm -q  p dvdm q"
  by (metis add.inverse_inverse dvdm_smult smult_1_left smult_minus_left)


(*TODO: simp?*)
lemma Mp_const_poly: "Mp [:a:] = [:a mod m:]"   
  by (simp add: Mp_def M_def Polynomial.map_poly_pCons)

lemma dvdm_imp_div_mod:
  assumes "u dvdm g"
  shows "q r. g = q*u + smult m r"
proof -
  obtain q where q: "Mp g = Mp (u*q)" 
    using assms unfolding dvdm_def by fast
  have "(u*q) = Mp (u*q) + smult m (Dp (u*q))"
    by (simp add: poly_mod.Dp_Mp_eq[of "u*q"])
  hence uq: "Mp (u*q) = (u*q) - smult m (Dp (u*q))"
    by auto  
  have g: "g = Mp g + smult m (Dp g)"
    by (simp add: poly_mod.Dp_Mp_eq[of "g"])
  also have "... = poly_mod.Mp m (u*q) + smult m (Dp g)" using q by simp
  also have "... = u * q - smult m (Dp (u * q)) + smult m (Dp g)" 
    unfolding uq by auto
  also have "... = u * q + smult m (-Dp (u*q)) + smult m (Dp g)" by auto  
  also have "... = u * q + smult m (-Dp (u*q) + Dp g)" 
    unfolding smult_add_right by auto
  also have "... = q * u + smult m (-Dp (u*q) + Dp g)" by auto
  finally show ?thesis by auto
qed

corollary div_mod_iff_dvdm:
  shows "a dvdm b = (q r. b = q * a + Polynomial.smult m r)"
  using div_mod_imp_dvdm dvdm_imp_div_mod by blast

lemma dvdmE':
  assumes "p dvdm q" and "r. q =m p * Mp r  thesis"
  shows thesis
  using assms by (auto simp: dvdm_def)

end

context poly_mod_2
begin
lemma factorization_m_mem_dvdm: assumes fact: "factorization_m f (c,fs)" 
  and mem: "Mp g ∈# image_mset Mp fs" 
shows "g dvdm f" 
proof - 
  from fact have "factorization_m f (Mf (c, fs))" by auto
  then obtain l where f: "factorization_m f (l, image_mset Mp fs)" by (auto simp: Mf_def)
  from multi_member_split[OF mem] obtain ls where 
    fs: "image_mset Mp fs = {# Mp g #} + ls" by auto
  from f[unfolded fs split factorization_m_def] show "g dvdm f" 
    unfolding dvdm_def
    by (intro exI[of _ "smult l (prod_mset ls)"], auto simp del: Mp_smult 
        simp add: Mp_smult(2)[of _ "Mp g * prod_mset ls", symmetric], simp)
qed

lemma dvdm_degree: "monic u  u dvdm f  Mp f  0  degree u  degree f"
  using dvdm_imp_degree_le m1 by blast

end

lemma (in poly_mod_prime) pl_dvdm_imp_p_dvdm:
  assumes l0: "l  0" 
  and pl_dvdm: "poly_mod.dvdm (p^l) a b"
  shows "a dvdm b"
proof -
  from l0 have l_gt_0: "l > 0" by auto
  with m1 interpret pl: poly_mod_2 "p^l" by (unfold_locales, auto)
  from l_gt_0 have p_rw: "p * p ^ (l - 1) = p ^ l"
    by (cases l) simp_all 
  obtain q r where b: "b = q * a + smult (p^l) r" using pl.dvdm_imp_div_mod[OF pl_dvdm] by auto
  have "smult (p^l) r = smult p (smult (p ^ (l - 1)) r)" unfolding smult_smult p_rw ..
  hence b2: "b = q * a + smult p (smult (p ^ (l - 1)) r)" using b by auto
  show ?thesis
    by (rule div_mod_imp_dvdm, rule exI[of _ q], 
        rule exI[of _ "(smult (p ^ (l - 1)) r)"], auto simp add: b2)
qed

end

Theory Poly_Mod_Finite_Field

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Polynomials in a Finite Field›
text ‹We connect polynomials in a prime field with integer polynomials modulo some prime.›

theory Poly_Mod_Finite_Field
  imports
  Finite_Field
  Polynomial_Interpolation.Ring_Hom_Poly
  "HOL-Types_To_Sets.Types_To_Sets"
  Missing_Multiset2
  Poly_Mod
begin

(* TODO: Move -- General transfer rule *)
declare rel_mset_Zero[transfer_rule]

lemma mset_transfer[transfer_rule]: "(list_all2 rel ===> rel_mset rel) mset mset"
proof (intro rel_funI)
  show "list_all2 rel xs ys  rel_mset rel (mset xs) (mset ys)" for xs ys
  proof (induct xs arbitrary: ys)
    case Nil
    then show ?case by auto
  next
    case IH: (Cons x xs)
    then show ?case by (auto dest!:msed_rel_invL simp: list_all2_Cons1 intro!:rel_mset_Plus)
  qed
qed


abbreviation to_int_poly :: "'a :: finite mod_ring poly  int poly" where
  "to_int_poly  map_poly to_int_mod_ring"

interpretation to_int_poly_hom: map_poly_inj_zero_hom to_int_mod_ring ..

lemma irreducibled_def_0:
  fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  shows "irreducibled f = (degree f  0  
  ( g h. degree g  0  degree h  0  f  g * h))"
proof-
  have "degree g  0  g  0" for g :: "'a poly" by auto
  note 1 = degree_mult_eq[OF this this, simplified]
  then show ?thesis by (force elim!: irreducibledE)
qed

subsection ‹Transferring to class-based mod-ring›

locale poly_mod_type = poly_mod m
  for m and ty :: "'a :: nontriv itself" +
  assumes m: "m = CARD('a)"
begin

lemma m1: "m > 1" using nontriv[where 'a = 'a] by (auto simp:m)

sublocale poly_mod_2 using m1 by unfold_locales

definition MP_Rel :: "int poly  'a mod_ring poly  bool"
  where "MP_Rel f f'  (Mp f = to_int_poly f')"

definition M_Rel :: "int  'a mod_ring  bool"
  where "M_Rel x x'  (M x = to_int_mod_ring x')"

definition "MF_Rel  rel_prod M_Rel (rel_mset MP_Rel)"

lemma to_int_mod_ring_plus: "to_int_mod_ring ((x :: 'a mod_ring) + y) = M (to_int_mod_ring x + to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma to_int_mod_ring_times: "to_int_mod_ring ((x :: 'a mod_ring) * y) = M (to_int_mod_ring x * to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma degree_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) degree_m degree"
  unfolding MP_Rel_def rel_fun_def 
  by (auto intro!: degree_map_poly)

lemma eq_M_Rel[transfer_rule]: "(M_Rel ===> M_Rel ===> (=)) (λ x y. M x = M y) (=)"
  unfolding M_Rel_def rel_fun_def by auto

interpretation to_int_mod_ring_hom: map_poly_inj_zero_hom to_int_mod_ring..

lemma eq_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (=m) (=)"
  unfolding MP_Rel_def rel_fun_def by auto

lemma eq_Mf_Rel[transfer_rule]: "(MF_Rel ===> MF_Rel ===> (=)) (λ x y. Mf x = Mf y) (=)"
proof (intro rel_funI, goal_cases)
  case (1 cfs Cfs dgs Dgs)
  obtain c fs where cfs: "cfs = (c,fs)" by force
  obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
  obtain d gs where dgs: "dgs = (d,gs)" by force
  obtain D Gs where Dgs: "Dgs = (D,Gs)" by force
  note pairs = cfs Cfs dgs Dgs
  from 1[unfolded pairs MF_Rel_def rel_prod.simps]
  have *[transfer_rule]: "M_Rel c C" "M_Rel d D" "rel_mset MP_Rel fs Fs" "rel_mset MP_Rel gs Gs" 
    by auto  
  have eq1: "(M c = M d) = (C = D)" by transfer_prover
  from *(3)[unfolded rel_mset_def] obtain fs' Fs' where fs_eq: "mset fs' = fs" "mset Fs' = Fs"
    and rel_f: "list_all2 MP_Rel fs' Fs'" by auto
  from *(4)[unfolded rel_mset_def] obtain gs' Gs' where gs_eq: "mset gs' = gs" "mset Gs' = Gs"
    and rel_g: "list_all2 MP_Rel gs' Gs'" by auto
  have eq2: "(image_mset Mp fs = image_mset Mp gs) = (Fs = Gs)" 
    using *(3-4)
  proof (induct fs arbitrary: Fs gs Gs)
    case (empty Fs gs Gs)
    from empty(1) have Fs: "Fs = {#}" unfolding rel_mset_def by auto
    with empty show ?case by (cases gs; cases Gs; auto simp: rel_mset_def)
  next
    case (add f fs Fs' gs' Gs')
    note [transfer_rule] = add(3)
    from msed_rel_invL[OF add(2)]
    obtain Fs F where Fs': "Fs' = Fs + {#F#}" and rel[transfer_rule]: 
      "MP_Rel f F" "rel_mset MP_Rel fs Fs" by auto      
    note IH = add(1)[OF rel(2)]
    {      
      from add(3)[unfolded rel_mset_def] obtain gs Gs where id: "mset gs = gs'" "mset Gs = Gs'" 
        and rel: "list_all2 MP_Rel gs Gs" by auto
      have "Mp f ∈# image_mset Mp gs'  F ∈# Gs'" 
      proof -
        have "?thesis = ((Mp f  Mp ` set gs) = (F  set Gs))" 
          unfolding id[symmetric] by simp
        also have  using rel
        proof (induct gs Gs rule: list_all2_induct)
          case (Cons g gs G Gs)
          note [transfer_rule] = Cons(1-2)
          have id: "(Mp g = Mp f) = (F = G)" by (transfer, auto)
          show ?case using id Cons(3) by auto
        qed auto
        finally show ?thesis by simp
      qed
    } note id = this
    show ?case
    proof (cases "Mp f ∈# image_mset Mp gs'")
      case False
      have "Mp f ∈# image_mset Mp (fs + {#f#})" by auto
      with False have F: "image_mset Mp (fs + {#f#})  image_mset Mp gs'" by metis
      with False[unfolded id] show ?thesis unfolding Fs' by auto
    next
      case True
      then obtain g where fg: "Mp f = Mp g" and g: "g ∈# gs'" by auto
      from g obtain gs where gs': "gs' = add_mset g gs" by (rule mset_add)
      from msed_rel_invL[OF add(3)[unfolded gs']]
      obtain Gs G where Gs': "Gs' = Gs + {# G #}" and gG[transfer_rule]: "MP_Rel g G" and 
        gsGs: "rel_mset MP_Rel gs Gs" by auto
      have FG: "F = G" by (transfer, simp add: fg)
      note IH = IH[OF gsGs]
      show ?thesis unfolding gs' Fs' Gs' by (simp add: fg IH FG)
    qed
  qed
  show "(Mf cfs = Mf dgs) = (Cfs = Dgs)" unfolding pairs Mf_def split
    by (simp add: eq1 eq2)
qed

lemmas coeff_map_poly_of_int = coeff_map_poly[of of_int, OF of_int_0]

lemma plus_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) (+) (+)"
  unfolding MP_Rel_def 
proof (intro rel_funI, goal_cases)
  case (1 x f y g)
  have "Mp (x + y) = Mp (Mp x + Mp y)" by simp
  also have " = Mp (map_poly to_int_mod_ring f + map_poly to_int_mod_ring g)" unfolding 1 ..
  also have " = map_poly to_int_mod_ring (f + g)" unfolding poly_eq_iff Mp_coeff 
       by (auto simp: to_int_mod_ring_plus)
  finally show ?case .
qed

lemma times_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))"
  unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x f y g)
  have "Mp (x * y) = Mp (Mp x * Mp y)" by simp
  also have " = Mp (map_poly to_int_mod_ring f * map_poly to_int_mod_ring g)" unfolding 1 ..
  also have " = map_poly to_int_mod_ring (f * g)"
  proof -
    { fix n :: nat
      define A where "A = {.. n}" 
      have "finite A" unfolding A_def by auto
      then have "M (in. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) =
           to_int_mod_ring (in. coeff f i * coeff g (n - i))"
        unfolding A_def[symmetric]
      proof (induct A)
        case (insert a A)
        have "?case = ?case" (is "(?l = ?r) = _") by simp
        have "?r = to_int_mod_ring (coeff f a * coeff g (n - a) + (i A. coeff f i * coeff g (n - i)))" 
          using insert(1-2) by auto
        note r = this[unfolded to_int_mod_ring_plus to_int_mod_ring_times]
        from insert(1-2) have "?l = M (to_int_mod_ring (coeff f a) * to_int_mod_ring (coeff g (n - a)) 
          + M (iA. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))))" 
          by simp
        also have "M (iA. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) = to_int_mod_ring (iA. coeff f i * coeff g (n - i))"
          unfolding insert ..
        finally
        show ?case unfolding r by simp
      qed auto
    }
    then show ?thesis by (auto intro!:poly_eqI simp: coeff_mult  Mp_coeff)
  qed
  finally show ?case .
qed

lemma smult_MP_Rel[transfer_rule]: "(M_Rel ===> MP_Rel ===> MP_Rel) smult smult"
  unfolding MP_Rel_def M_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x x' f f')
  thus ?case unfolding poly_eq_iff coeff Mp_coeff
    coeff_smult M_def
  proof (intro allI, goal_cases)
    case (1 n)
    have "x * coeff f n mod m = (x mod m) * (coeff f n mod m) mod m" 
      by (simp add: mod_simps)
    also have " = to_int_mod_ring x' * (to_int_mod_ring (coeff f' n)) mod m" 
      using 1 by auto
    also have "  = to_int_mod_ring (x' * coeff f' n)" 
      unfolding to_int_mod_ring_times M_def by simp
    finally show ?case by auto
  qed
qed

lemma one_M_Rel[transfer_rule]: "M_Rel 1 1"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma one_MP_Rel[transfer_rule]: "MP_Rel 1 1"
  unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def 
  unfolding m by auto

lemma zero_M_Rel[transfer_rule]: "M_Rel 0 0"
  unfolding M_Rel_def M_def 
  unfolding m by auto

lemma zero_MP_Rel[transfer_rule]: "MP_Rel 0 0"
  unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
  unfolding m by auto

lemma listprod_MP_Rel[transfer_rule]: "(list_all2 MP_Rel ===> MP_Rel) prod_list prod_list"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  thus ?case 
  proof (induct xs ys rule: list_all2_induct)
    case (Cons x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one_MP_Rel)
qed

lemma prod_mset_MP_Rel[transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel) prod_mset prod_mset"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  have "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))" "MP_Rel 1 1" by transfer_prover+
  from 1 this show ?case
  proof (induct xs ys rule: rel_mset_induct)
    case (add R x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one_MP_Rel)
qed

lemma right_unique_MP_Rel[transfer_rule]: "right_unique MP_Rel"
  unfolding right_unique_def MP_Rel_def by auto

lemma M_to_int_mod_ring: "M (to_int_mod_ring (x :: 'a mod_ring)) = to_int_mod_ring x"
  unfolding M_def unfolding m by (transfer, auto)

lemma Mp_to_int_poly: "Mp (to_int_poly (f :: 'a mod_ring poly)) = to_int_poly f"
  by (auto simp: poly_eq_iff Mp_coeff M_to_int_mod_ring)

lemma right_total_M_Rel[transfer_rule]: "right_total M_Rel"
  unfolding right_total_def M_Rel_def using M_to_int_mod_ring by blast

lemma left_total_M_Rel[transfer_rule]: "left_total M_Rel"
  unfolding left_total_def M_Rel_def[abs_def] 
proof
  fix x
  show " x' :: 'a mod_ring. M x = to_int_mod_ring x'"  unfolding M_def unfolding m
    by (rule exI[of _ "of_int x"], transfer, simp)
qed

lemma bi_total_M_Rel[transfer_rule]: "bi_total M_Rel" 
  using right_total_M_Rel left_total_M_Rel by (metis bi_totalI)

lemma right_total_MP_Rel[transfer_rule]: "right_total MP_Rel"
  unfolding right_total_def MP_Rel_def
proof
  fix f :: "'a mod_ring poly"
  show "x. Mp x = to_int_poly f"
    by (intro exI[of _ "to_int_poly f"], simp add: Mp_to_int_poly)
qed

lemma to_int_mod_ring_of_int_M: "to_int_mod_ring (of_int x :: 'a mod_ring) = M x" unfolding M_def
  unfolding m by transfer auto

lemma Mp_f_representative: "Mp f = to_int_poly (map_poly of_int f :: 'a mod_ring poly)"
  unfolding Mp_def by (auto intro: poly_eqI simp: coeff_map_poly to_int_mod_ring_of_int_M)

lemma left_total_MP_Rel[transfer_rule]: "left_total MP_Rel"
  unfolding left_total_def MP_Rel_def[abs_def] using Mp_f_representative by blast

lemma bi_total_MP_Rel[transfer_rule]: "bi_total MP_Rel"
  using right_total_MP_Rel left_total_MP_Rel by (metis bi_totalI)

lemma bi_total_MF_Rel[transfer_rule]: "bi_total MF_Rel"
  unfolding MF_Rel_def[abs_def] 
  by (intro prod.bi_total_rel multiset.bi_total_rel bi_total_MP_Rel bi_total_M_Rel)

lemma right_total_MF_Rel[transfer_rule]: "right_total MF_Rel"
  using bi_total_MF_Rel unfolding bi_total_alt_def by auto

lemma left_total_MF_Rel[transfer_rule]: "left_total MF_Rel"
  using bi_total_MF_Rel unfolding bi_total_alt_def by auto

lemma domain_RT_rel[transfer_domain_rule]: "Domainp MP_Rel = (λ f. True)"
proof
  fix f :: "int poly"
  show "Domainp MP_Rel f = True" unfolding MP_Rel_def[abs_def] Domainp.simps
    by (auto simp: Mp_f_representative)
qed

lemma mem_MP_Rel[transfer_rule]: "(MP_Rel ===> rel_set MP_Rel ===> (=)) (λ x Y. y  Y. eq_m x y) (∈)"
proof (intro rel_funI iffI)
  fix x y X Y assume xy: "MP_Rel x y" and XY: "rel_set MP_Rel X Y"
  { assume "x'  X. x =m x'"
    then obtain x' where x'X: "x'  X" and xx': "x =m x'" by auto
    with xy have x'y: "MP_Rel x' y" by (auto simp: MP_Rel_def)
    from rel_setD1[OF XY x'X] obtain y' where "MP_Rel x' y'" and "y'  Y" by auto
    with x'y
    show "y  Y" by (auto simp: MP_Rel_def)
  }
  assume "y  Y"
  from rel_setD2[OF XY this] obtain x' where x'X: "x'  X" and x'y: "MP_Rel x' y" by auto
  from xy x'y have "x =m x'" by (auto simp: MP_Rel_def)
  with x'X show "x'  X. x =m x'" by auto
qed

lemma conversep_MP_Rel_OO_MP_Rel [simp]: "MP_Rel¯¯ OO MP_Rel = (=)"
  using Mp_to_int_poly by (intro ext, auto simp: OO_def MP_Rel_def)

lemma MP_Rel_OO_conversep_MP_Rel [simp]: "MP_Rel OO MP_Rel¯¯ = eq_m"
  by (intro ext, auto simp: OO_def MP_Rel_def Mp_f_representative)

lemma conversep_MP_Rel_OO_eq_m [simp]: "MP_Rel¯¯ OO eq_m = MP_Rel¯¯"
  by (intro ext, auto simp: OO_def MP_Rel_def)

lemma eq_m_OO_MP_Rel [simp]: "eq_m OO MP_Rel = MP_Rel"
  by (intro ext, auto simp: OO_def MP_Rel_def)

lemma eq_mset_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> rel_mset MP_Rel ===> (=)) (rel_mset eq_m) (=)"
proof (intro rel_funI iffI)
  fix A B X Y
  assume AX: "rel_mset MP_Rel A X" and BY: "rel_mset MP_Rel B Y"
  {
    assume AB: "rel_mset eq_m A B"
    from AX have "rel_mset MP_Rel¯¯ X A" by (simp add: multiset.rel_flip)
    note rel_mset_OO[OF this AB]
    note rel_mset_OO[OF this BY]
    then show "X = Y" by (simp add: multiset.rel_eq)
  }
  assume "X = Y"
  with BY have "rel_mset MP_Rel¯¯ X B" by (simp add: multiset.rel_flip)
  from rel_mset_OO[OF AX this]
  show "rel_mset eq_m A B" by simp
qed

lemma dvd_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (dvdm) (dvd)"
  unfolding dvdm_def[abs_def] dvd_def[abs_def]
  by transfer_prover

lemma irreducible_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible_m irreducible"
  unfolding irreducible_m_def irreducible_def
  by transfer_prover

lemma irreducibled_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducibled_m irreducibled"
  unfolding irreducibled_m_def[abs_def] irreducibled_def[abs_def]
  by transfer_prover

lemma UNIV_M_Rel[transfer_rule]: "rel_set M_Rel {0..<m} UNIV"
  unfolding rel_set_def M_Rel_def[abs_def] M_def 
  by (auto simp: M_def m, goal_cases, metis to_int_mod_ring_of_int_mod_ring, (transfer, auto)+)

lemma coeff_MP_Rel [transfer_rule]: "(MP_Rel ===> (=) ===> M_Rel) coeff coeff"
  unfolding rel_fun_def M_Rel_def MP_Rel_def Mp_coeff[symmetric] by auto

lemma M_1_1: "M 1 = 1" unfolding M_def unfolding m by simp

lemma square_free_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) square_free_m square_free"
  unfolding square_free_m_def[abs_def] square_free_def[abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma mset_factors_m_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel ===> (=)) mset_factors_m mset_factors"
  unfolding mset_factors_def mset_factors_m_def
  by (transfer_prover_start, transfer_step+, auto dest:eq_m_irreducible_m)

lemma coprime_MP_Rel [transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) coprime_m coprime"
  unfolding coprime_m_def[abs_def] coprime_def' [abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma prime_elem_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) prime_elem_m prime_elem"
  unfolding prime_elem_m_def prime_elem_def by transfer_prover

end

context poly_mod_2 begin

lemma non_empty: "{0..<m}  {}" using m1 by auto

lemma type_to_set:
  assumes type_def: "(Rep :: 'b  int) Abs. type_definition Rep Abs {0 ..< m :: int}"
  shows "class.nontriv (TYPE('b))" (is ?a) and "m = int CARD('b)" (is ?b)
proof -
  from type_def obtain rep :: "'b  int" and abs :: "int  'b" where t: "type_definition rep abs {0 ..< m}" by auto
  have "card (UNIV :: 'b set) = card {0 ..< m}" using t by (rule type_definition.card)
  also have " = m" using m1 by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using m1 by auto
qed

end

locale poly_mod_prime_type = poly_mod_type m ty for m :: int and
  ty :: "'a :: prime_card itself"
begin 

lemma factorization_MP_Rel [transfer_rule]:
  "(MP_Rel ===> MF_Rel ===> (=)) factorization_m (factorization Irr_Mon)"
  unfolding rel_fun_def
proof (intro allI impI, goal_cases)
  case (1 f F cfs Cfs)
  note [transfer_rule] = 1(1)
  obtain c fs where cfs: "cfs = (c,fs)" by force
  obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
  from 1(2)[unfolded rel_prod.simps cfs Cfs MF_Rel_def] 
  have tr[transfer_rule]: "M_Rel c C" "rel_mset MP_Rel fs Fs" by auto
  have eq: "(f =m smult c (prod_mset fs) = (F = smult C (prod_mset Fs)))" 
    by transfer_prover
  have "set_mset Fs  Irr_Mon = ( x ∈# Fs. irreducibled x  monic x)" unfolding Irr_Mon_def by auto
  also have " = (f∈#fs. irreducibled_m f  monic (Mp f))"
  proof (rule sym, transfer_prover_start, transfer_step+)
    {
      fix f
      assume "f ∈# fs" 
      have "monic (Mp f)  M (coeff f (degree_m f)) = M 1"
        unfolding Mp_coeff[symmetric] by simp
    }
    thus "(f∈#fs. irreducibled_m f  monic (Mp f)) = 
      (x∈#fs. irreducibled_m x  M (coeff x (degree_m x)) = M 1)" by auto
  qed
  finally
  show "factorization_m f cfs = factorization Irr_Mon F Cfs" unfolding cfs Cfs
    factorization_m_def factorization_def split eq by simp
qed

lemma unique_factorization_MP_Rel [transfer_rule]: "(MP_Rel ===> MF_Rel ===> (=))
  unique_factorization_m (unique_factorization Irr_Mon)"
  unfolding rel_fun_def
proof (intro allI impI, goal_cases)
  case (1 f F cfs Cfs)
  note [transfer_rule] = 1(1,2)
  let ?F = "factorization Irr_Mon F" 
  let ?f = "factorization_m f" 
  let ?R = "Collect ?F" 
  let ?L = "Mf ` Collect ?f"
  note X_to_x = right_total_MF_Rel[unfolded right_total_def, rule_format]
  {
    fix X
    assume "X  ?R" 
    hence F: "?F X" by simp
    from X_to_x[of X] obtain x where rel[transfer_rule]: "MF_Rel x X" by blast
    from F[untransferred] have "Mf x  ?L" by blast
    with rel have " x. Mf x  ?L  MF_Rel x X" by blast
  } note R_to_L = this
  show "unique_factorization_m f cfs = unique_factorization Irr_Mon F Cfs" unfolding 
    unique_factorization_m_def unique_factorization_def  
  proof -
    have fF: "?F Cfs = ?f cfs" by transfer simp
    have "(?L = {Mf cfs}) = (?L  {Mf cfs}  Mf cfs  ?L)" by blast
    also have "?L  {Mf cfs} = ( dfs. ?f dfs  Mf dfs = Mf cfs)" by blast
    also have " = ( y. ?F y  y = Cfs)" (is "?left = ?right")
    proof (rule; intro allI impI)
      fix Dfs
      assume *: ?left and F: "?F Dfs" 
      from X_to_x[of Dfs] obtain dfs where [transfer_rule]: "MF_Rel dfs Dfs" by auto
      from F[untransferred] have f: "?f dfs" .
      from *[rule_format, OF f] have eq: "Mf dfs = Mf cfs" by simp
      have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp) 
      thus "Dfs = Cfs" using eq by simp
    next
      fix dfs
      assume *: ?right and f: "?f dfs" 
      from left_total_MF_Rel obtain Dfs where 
        rel[transfer_rule]: "MF_Rel dfs Dfs" unfolding left_total_def by blast
      have "?F Dfs" by (transfer, rule f)
      from *[rule_format, OF this] have eq: "Dfs = Cfs" .
      have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp) 
      thus "Mf dfs = Mf cfs" using eq by simp
    qed    
    also have "Mf cfs  ?L = ( dfs. ?f dfs  Mf cfs = Mf dfs)" by auto
    also have " = ?F Cfs"  unfolding fF
    proof
      assume " dfs. ?f dfs  Mf cfs  = Mf dfs" 
      then obtain dfs where f: "?f dfs" and id: "Mf dfs = Mf cfs" by auto
      from f have "?f (Mf dfs)" by simp
      from this[unfolded id] show "?f cfs" by simp
    qed blast
    finally show "(?L = {Mf cfs}) = (?R = {Cfs})" by auto
  qed
qed

end

context begin
private lemma 1: "poly_mod_type TYPE('a :: nontriv) m = (m = int CARD('a))"
  and 2: "class.nontriv TYPE('a) = (CARD('a)  2)"
  unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto

private lemma 3: "poly_mod_prime_type TYPE('b) m = (m = int CARD('b))"
  and 4: "class.prime_card TYPE('b :: prime_card) = prime CARD('b :: prime_card)" 
  unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto

lemmas poly_mod_type_simps = 1 2 3 4
end


lemma remove_duplicate_premise: "(PROP P  PROP P  PROP Q)  (PROP P  PROP Q)" (is "?l  ?r")
proof (intro Pure.equal_intr_rule)
  assume p: "PROP P" and ppq: "PROP ?l"
  from ppq[OF p p] show "PROP Q".
next
  assume p: "PROP P" and pq: "PROP ?r"
  from pq[OF p] show "PROP Q".
qed

context poly_mod_prime begin

lemma type_to_set:
  assumes type_def: "(Rep :: 'b  int) Abs. type_definition Rep Abs {0 ..< p :: int}"
  shows "class.prime_card (TYPE('b))" (is ?a) and "p = int CARD('b)" (is ?b)
proof -
  from prime have p2: "p  2" by (rule prime_ge_2_int)
  from type_def obtain rep :: "'b  int" and abs :: "int  'b" where t: "type_definition rep abs {0 ..< p}" by auto
  have "card (UNIV :: 'b set) = card {0 ..< p}" using t by (rule type_definition.card)
  also have " = p" using p2 by auto
  finally show ?b ..
  then show ?a unfolding class.prime_card_def using prime p2 by auto
qed
end

(* it will be nice to be able to automate this *)

lemmas (in poly_mod_type) prime_elem_m_dvdm_multD = prime_elem_dvd_multD
  [where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_2) prime_elem_m_dvdm_multD = poly_mod_type.prime_elem_m_dvdm_multD
  [unfolded poly_mod_type_simps, internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas(in poly_mod_prime_type) degree_m_mult_eq = degree_mult_eq
  [where 'a = "'a mod_ring", untransferred]
lemmas(in poly_mod_prime) degree_m_mult_eq = poly_mod_prime_type.degree_m_mult_eq
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma(in poly_mod_prime) irreducibled_lifting:
  assumes n: "n  0"
    and deg: "poly_mod.degree_m (p^n) f = degree_m f"
    and irr: "irreducibled_m f"
  shows "poly_mod.irreducibled_m (p^n) f"
proof -
  interpret q: poly_mod_2 "p^n" unfolding poly_mod_2_def using n m1 by auto
  show "q.irreducibled_m f"
  proof (rule q.irreducibled_mI)
    from deg irr show "q.degree_m f > 0" by (auto elim: irreducibled_mE)
    then have pdeg_f: "degree_m f  0" by (simp add: deg)
    note pMp_Mp = Mp_Mp_pow_is_Mp[OF n m1]
    fix g h
    assume deg_g: "degree g < q.degree_m f" and deg_h: "degree h < q.degree_m f"
      and eq: "q.eq_m f (g * h)"
    from eq have p_f: "f =m (g * h)" using pMp_Mp by metis
    have "¬g =m 0" and "¬h =m 0"
      apply (metis degree_0 mult_zero_left Mp_0 p_f pdeg_f poly_mod.mult_Mp(1))
      by (metis degree_0 mult_eq_0_iff Mp_0 mult_Mp(2) p_f pdeg_f)
    note [simp] = degree_m_mult_eq[OF this]
    from degree_m_le[of g] deg_g
    have 2: "degree_m g < degree_m f" by (fold deg, auto)
    from degree_m_le[of h] deg_h
    have 3: "degree_m h < degree_m f" by (fold deg, auto)
    from irreducibled_mD(2)[OF irr 2 3] p_f
    show False by auto
  qed
qed

(* Lifting UFD properties *)
lemmas (in poly_mod_prime_type) mset_factors_exist =
  mset_factors_exist[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_exist = poly_mod_prime_type.mset_factors_exist
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) mset_factors_unique =
  mset_factors_unique[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_unique = poly_mod_prime_type.mset_factors_unique
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) prime_elem_iff_irreducible =
  prime_elem_iff_irreducible[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) prime_elem_iff_irreducible[simp] = poly_mod_prime_type.prime_elem_iff_irreducible
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) irreducible_connect =
  irreducible_connect_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_connect[simp] = poly_mod_prime_type.irreducible_connect
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) irreducible_degree =
  irreducible_degree_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_degree = poly_mod_prime_type.irreducible_degree
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]


end

Theory Karatsuba_Multiplication

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Karatsuba's Multiplication Algorithm for Polynomials›
theory Karatsuba_Multiplication
imports 
  Polynomial_Interpolation.Missing_Polynomial
begin

lemma karatsuba_main_step: fixes f :: "'a :: comm_ring_1 poly"
  assumes f: "f = monom_mult n f1 + f0" and g: "g = monom_mult n g1 + g0" 
  shows 
    "monom_mult (n + n) (f1 * g1) + (monom_mult n (f1 * g1 - (f1 - f0) * (g1 - g0) + f0 * g0) + f0 * g0) = f * g"
  unfolding assms
  by (auto simp: field_simps mult_monom monom_mult_def)  

lemma karatsuba_single_sided: fixes f :: "'a :: comm_ring_1 poly" 
  assumes "f = monom_mult n f1 + f0"
  shows "monom_mult n (f1 * g) + f0 * g = f * g"
  unfolding assms by (auto simp: field_simps mult_monom monom_mult_def)  


definition split_at :: "nat  'a list  'a list × 'a list" where 
  [code del]: "split_at n xs = (take n xs, drop n xs)" 
  
lemma split_at_code[code]: 
  "split_at n [] = ([],[])"
  "split_at n (x # xs) = (if n = 0 then ([], x # xs) else case split_at (n-1) xs of (bef,aft)
     (x # bef, aft))"
  unfolding split_at_def by (force, cases n, auto)

fun coeffs_minus :: "'a :: ab_group_add list  'a list  'a list" where
  "coeffs_minus (x # xs) (y # ys) = ((x - y) # coeffs_minus xs ys)" 
| "coeffs_minus xs [] = xs" 
| "coeffs_minus [] ys = map uminus ys" 
  
text ‹The following constant determines at which size we will switch to the standard 
   multiplication algorithm.›
definition karatsuba_lower_bound where [termination_simp]: "karatsuba_lower_bound = (7 :: nat)" 

fun karatsuba_main :: "'a :: comm_ring_1 list  nat  'a list  nat  'a poly" where
  "karatsuba_main f n g m = (if n  karatsuba_lower_bound  m  karatsuba_lower_bound then 
    let ff = poly_of_list f in foldr (λa p. smult a ff + pCons 0 p) g 0
   else let n2 = n div 2 in 
   if m > n2 then (case split_at n2 f of 
   (f0,f1)  case split_at n2 g of
   (g0,g1)  let 
      p1 = karatsuba_main f1 (n - n2) g1 (m - n2);
      p2 = karatsuba_main (coeffs_minus f1 f0) n2 (coeffs_minus g1 g0) n2;
      p3 = karatsuba_main f0 n2 g0 n2 
      in monom_mult (n2 + n2) p1 + (monom_mult n2 (p1 - p2 + p3) + p3))
    else case split_at n2 f of
    (f0,f1)  let 
       p1 = karatsuba_main f1 (n - n2) g m; 
       p2 = karatsuba_main f0 n2 g m
     in monom_mult n2 p1 + p2)" 

declare karatsuba_main.simps[simp del]

lemma poly_of_list_split_at: assumes "split_at n f = (f0,f1)" 
  shows "poly_of_list f = monom_mult n (poly_of_list f1) + poly_of_list f0"
proof -
  from assms have id: "f1 = drop n f" "f0 = take n f" unfolding split_at_def by auto
  show ?thesis unfolding id
  proof (rule poly_eqI)
    fix i
    show "coeff (poly_of_list f) i = 
      coeff (monom_mult n (poly_of_list (drop n f)) + poly_of_list (take n f)) i" 
      unfolding monom_mult_def coeff_monom_mult coeff_add poly_of_list_def coeff_Poly
      by (cases "n  i"; cases "i  length f", auto simp: nth_default_nth nth_default_beyond)
  qed
qed
        
lemma coeffs_minus: "poly_of_list (coeffs_minus f1 f0) = poly_of_list f1 - poly_of_list f0" 
proof (rule poly_eqI, unfold poly_of_list_def coeff_diff coeff_Poly)
  fix i
  show "nth_default 0 (coeffs_minus f1 f0) i = nth_default 0 f1 i - nth_default 0 f0 i" 
  proof (induct f1 f0 arbitrary: i rule: coeffs_minus.induct)
    case (1 x xs y ys)
    thus ?case by (cases i, auto)
  next
    case (3 x xs)
    thus ?case unfolding coeffs_minus.simps
      by (subst nth_default_map_eq[of uminus 0 0], auto)    
  qed auto
qed

lemma karatsuba_main: "karatsuba_main f n g m = poly_of_list f * poly_of_list g" 
proof (induct n arbitrary: f g m rule: less_induct)
  case (less n f g m)
  note simp[simp] = karatsuba_main.simps[of f n g m]
  show ?case (is "?lhs = ?rhs")
  proof (cases "(n  karatsuba_lower_bound  m  karatsuba_lower_bound) = False")
    case False
    hence lhs: "?lhs = foldr (λa p. smult a (poly_of_list f) + pCons 0 p) g 0" by simp
    have rhs: "?rhs = poly_of_list g * poly_of_list f" by simp 
    also have " = foldr (λa p. smult a (poly_of_list f) + pCons 0 p) (strip_while ((=) 0) g) 0" 
      unfolding times_poly_def fold_coeffs_def poly_of_list_impl ..
    also have " = ?lhs" unfolding lhs 
    proof (induct g)
      case (Cons x xs)
      have "xset xs. x = 0  foldr (λa p. smult a (Poly f) + pCons 0 p) xs 0 = 0" 
        by (induct xs, auto)        
      thus ?case using Cons by (auto simp: cCons_def Cons)
    qed auto
    finally show ?thesis by simp
  next
    case True
    let ?n2 = "n div 2" 
    have "?n2 < n" "n - ?n2 < n" using True unfolding karatsuba_lower_bound_def by auto
    note IH = less[OF this(1)] less[OF this(2)]
    obtain f1 f0 where f: "split_at ?n2 f = (f0,f1)" by force
    obtain g1 g0 where g: "split_at ?n2 g = (g0,g1)" by force
    note fsplit = poly_of_list_split_at[OF f]
    note gsplit = poly_of_list_split_at[OF g]
    show "?lhs = ?rhs" unfolding simp Let_def f g split IH True if_False coeffs_minus
      karatsuba_single_sided[OF fsplit] karatsuba_main_step[OF fsplit gsplit] by auto
  qed
qed


definition karatsuba_mult_poly :: "'a :: comm_ring_1 poly  'a poly  'a poly" where
  "karatsuba_mult_poly f g = (let ff = coeffs f; gg = coeffs g; n = length ff; m = length gg
    in (if n  karatsuba_lower_bound  m  karatsuba_lower_bound then if n  m 
    then foldr (λa p. smult a g + pCons 0 p) ff 0 
    else foldr (λa p. smult a f + pCons 0 p) gg 0 
    else if n  m 
    then karatsuba_main gg m ff n 
    else karatsuba_main ff n gg m))" 
  
lemma karatsuba_mult_poly: "karatsuba_mult_poly f g = f * g" 
proof -
  note d = karatsuba_mult_poly_def Let_def 
  let ?len = "length (coeffs f)  length (coeffs g)" 
  show ?thesis (is "?lhs = ?rhs")
  proof (cases "length (coeffs f)  karatsuba_lower_bound  length (coeffs g)  karatsuba_lower_bound")
    case True note outer = this
    show ?thesis
    proof (cases ?len)
      case True
      with outer have "?lhs = foldr (λa p. smult a g + pCons 0 p) (coeffs f) 0" unfolding d by auto
      also have " = ?rhs" unfolding times_poly_def fold_coeffs_def by auto
      finally show ?thesis .
    next
      case False
      with outer have "?lhs = foldr (λa p. smult a f + pCons 0 p) (coeffs g) 0" unfolding d by auto
      also have " = g * f" unfolding times_poly_def fold_coeffs_def by auto
      also have " = ?rhs" by simp
      finally show ?thesis .
    qed
  next
    case False note outer = this
    show ?thesis
    proof (cases ?len)
      case True   
      with outer have "?lhs = karatsuba_main (coeffs g) (length (coeffs g)) (coeffs f) (length (coeffs f))" 
        unfolding d by auto
      also have " = g * f" unfolding karatsuba_main by auto
      also have " = ?rhs" by auto
      finally show ?thesis .
    next
      case False
      with outer have "?lhs = karatsuba_main (coeffs f) (length (coeffs f)) (coeffs g) (length (coeffs g))" 
        unfolding d by auto
      also have " = ?rhs" unfolding karatsuba_main by auto
      finally show ?thesis .
    qed
  qed
qed

lemma karatsuba_mult_poly_code_unfold[code_unfold]: "(*) = karatsuba_mult_poly" 
  by (intro ext, unfold karatsuba_mult_poly, auto)

text ‹The following declaration will resolve a race-conflict between @{thm karatsuba_mult_poly_code_unfold}
  and @{thm monom_mult_unfold}.›
lemmas karatsuba_monom_mult_code_unfold[code_unfold] = 
  monom_mult_unfold[where f = "f :: 'a :: comm_ring_1 poly" for f, unfolded karatsuba_mult_poly_code_unfold]

end

Theory Polynomial_Record_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Record Based Version›

text ‹We provide an implementation for polynomials which may be parametrized
  by the ring- or field-operations. These don't have to be type-based!›

subsubsection ‹Definitions›

theory Polynomial_Record_Based
imports 
  Arithmetic_Record_Based
  Karatsuba_Multiplication
begin

context
  fixes ops :: "'i arith_ops_record" (structure)
begin
private abbreviation (input) zero where "zero  arith_ops_record.zero ops"
private abbreviation (input) one where "one  arith_ops_record.one ops"
private abbreviation (input) plus where "plus  arith_ops_record.plus ops"
private abbreviation (input) times where "times  arith_ops_record.times ops"
private abbreviation (input) minus where "minus  arith_ops_record.minus ops"
private abbreviation (input) uminus where "uminus  arith_ops_record.uminus ops"
private abbreviation (input) divide where "divide  arith_ops_record.divide ops"
private abbreviation (input) inverse where "inverse  arith_ops_record.inverse ops"
private abbreviation (input) modulo where "modulo  arith_ops_record.modulo ops"
private abbreviation (input) normalize where "normalize  arith_ops_record.normalize ops"
private abbreviation (input) unit_factor where "unit_factor  arith_ops_record.unit_factor ops"
private abbreviation (input) DP where "DP  arith_ops_record.DP ops"

definition is_poly :: "'i list  bool" where
  "is_poly xs  list_all DP xs  no_trailing (HOL.eq zero) xs"
                                        
definition cCons_i :: "'i  'i list  'i list" 
where
  "cCons_i x xs = (if xs = []  x = zero then [] else x # xs)"

fun plus_poly_i :: "'i list  'i list  'i list" where
  "plus_poly_i (x # xs) (y # ys) = cCons_i (plus x y) (plus_poly_i xs ys)"
| "plus_poly_i xs [] = xs"
| "plus_poly_i [] ys = ys"

definition uminus_poly_i :: "'i list  'i list" where
  [code_unfold]: "uminus_poly_i = map uminus"

fun minus_poly_i :: "'i list  'i list  'i list" where
  "minus_poly_i (x # xs) (y # ys) = cCons_i (minus x y) (minus_poly_i xs ys)"
| "minus_poly_i xs [] = xs"
| "minus_poly_i [] ys = uminus_poly_i ys"


abbreviation (input) zero_poly_i :: "'i list" where
  "zero_poly_i  []"

definition one_poly_i :: "'i list" where
  [code_unfold]: "one_poly_i = [one]"

definition smult_i :: "'i  'i list  'i list" where
  "smult_i a pp = (if a = zero then [] else strip_while ((=) zero) (map (times a) pp))"

definition sdiv_i :: "'i list  'i  'i list" where
  "sdiv_i pp a = (strip_while ((=) zero) (map (λ c. divide c a) pp))"

definition poly_of_list_i :: "'i list  'i list" where
  "poly_of_list_i = strip_while ((=) zero)"

fun coeffs_minus_i :: "'i list  'i list  'i list" where
  "coeffs_minus_i (x # xs) (y # ys) = (minus x y # coeffs_minus_i xs ys)" 
| "coeffs_minus_i xs [] = xs" 
| "coeffs_minus_i [] ys = map uminus ys" 
  
definition monom_mult_i :: "nat  'i list  'i list" where
  "monom_mult_i n xs = (if xs = [] then xs else replicate n zero @ xs)" 

fun karatsuba_main_i :: "'i list  nat  'i list  nat  'i list" where
  "karatsuba_main_i f n g m = (if n  karatsuba_lower_bound  m  karatsuba_lower_bound then 
   let ff = poly_of_list_i f in foldr (λa p. plus_poly_i (smult_i a ff) (cCons_i zero p)) g zero_poly_i
   else let n2 = n div 2 in 
   if m > n2 then (case split_at n2 f of 
   (f0,f1)  case split_at n2 g of
   (g0,g1)  let 
      p1 = karatsuba_main_i f1 (n - n2) g1 (m - n2);
      p2 = karatsuba_main_i (coeffs_minus_i f1 f0) n2 (coeffs_minus_i g1 g0) n2;
      p3 = karatsuba_main_i f0 n2 g0 n2 
      in plus_poly_i (monom_mult_i (n2 + n2) p1) 
        (plus_poly_i (monom_mult_i n2 (plus_poly_i (minus_poly_i p1 p2) p3)) p3))
    else case split_at n2 f of
    (f0,f1)  let 
       p1 = karatsuba_main_i f1 (n - n2) g m; 
       p2 = karatsuba_main_i f0 n2 g m
     in plus_poly_i (monom_mult_i n2 p1) p2)" 
  
definition times_poly_i :: "'i list  'i list  'i list" where
  "times_poly_i f g  (let n = length f; m = length g
    in (if n  karatsuba_lower_bound  m  karatsuba_lower_bound then if n  m then 
      foldr (λa p. plus_poly_i (smult_i a g) (cCons_i zero p)) f zero_poly_i else 
      foldr (λa p. plus_poly_i (smult_i a f) (cCons_i zero p)) g zero_poly_i else
      if n  m then karatsuba_main_i g m f n else karatsuba_main_i f n g m))"

definition coeff_i :: "'i list  nat  'i" where
  "coeff_i = nth_default zero"

definition degree_i :: "'i list  nat" where
  "degree_i pp  length pp - 1"

definition lead_coeff_i :: "'i list  'i" where
  "lead_coeff_i pp = (case pp of []  zero | _  last pp)"

definition monic_i :: "'i list  bool" where
  "monic_i pp = (lead_coeff_i pp = one)" 

fun minus_poly_rev_list_i :: "'i list  'i list  'i list" where
  "minus_poly_rev_list_i (x # xs) (y # ys) = (minus x y) # (minus_poly_rev_list_i xs ys)"
| "minus_poly_rev_list_i xs [] = xs"
| "minus_poly_rev_list_i [] (y # ys) = []"

fun divmod_poly_one_main_i :: "'i list  'i list  'i list 
   nat  'i list × 'i list" where
  "divmod_poly_one_main_i q r d (Suc n) = (let
     a = hd r;
     qqq = cCons_i a q;
     rr = tl (if a = zero then r else minus_poly_rev_list_i r (map (times a) d))
     in divmod_poly_one_main_i qqq rr d n)"
| "divmod_poly_one_main_i q r d 0 = (q,r)"

fun mod_poly_one_main_i :: "'i list  'i list 
   nat  'i list" where
  "mod_poly_one_main_i r d (Suc n) = (let
     a = hd r;
     rr = tl (if a = zero then r else minus_poly_rev_list_i r (map (times a) d))
     in mod_poly_one_main_i rr d n)"
| "mod_poly_one_main_i r d 0 = r"

definition pdivmod_monic_i :: "'i list  'i list  'i list × 'i list" where
  "pdivmod_monic_i cf cg  case 
     divmod_poly_one_main_i [] (rev cf) (rev cg) (1 + length cf - length cg)
     of (q,r)  (poly_of_list_i q, poly_of_list_i (rev r))"

definition dupe_monic_i :: "'i list  'i list  'i list  'i list  'i list  'i list × 'i list" where
  "dupe_monic_i D H S T U = (case pdivmod_monic_i (times_poly_i T U) D of (Q,R) 
     (plus_poly_i (times_poly_i S U) (times_poly_i H Q), R))"

definition of_int_poly_i :: "int poly  'i list" where
  "of_int_poly_i f = map (arith_ops_record.of_int ops) (coeffs f)" 

definition to_int_poly_i :: "'i list  int poly" where
  "to_int_poly_i f = poly_of_list (map (arith_ops_record.to_int ops) f)" 

definition dupe_monic_i_int :: "int poly  int poly  int poly  int poly  int poly  int poly × int poly" where
  "dupe_monic_i_int D H S T = (let 
      d = of_int_poly_i D;
      h = of_int_poly_i H;
      s = of_int_poly_i S;
      t = of_int_poly_i T 
    in (λ U. case dupe_monic_i d h s t (of_int_poly_i U) of
       (D',H')  (to_int_poly_i D', to_int_poly_i H')))"

definition div_field_poly_i :: "'i list  'i list  'i list" where 
  "div_field_poly_i cf cg = (
      if cg = [] then zero_poly_i
        else let ilc = inverse (last cg); ch = map (times ilc) cg;
                 q = fst (divmod_poly_one_main_i [] (rev cf) (rev ch) (1 + length cf - length cg))
             in poly_of_list_i ((map (times ilc) q)))"

definition mod_field_poly_i :: "'i list  'i list  'i list" where 
  "mod_field_poly_i cf cg = (
      if cg = [] then cf
        else let ilc = inverse (last cg); ch = map (times ilc) cg;
                 r = mod_poly_one_main_i (rev cf) (rev ch) (1 + length cf - length cg)
             in poly_of_list_i (rev r))"

definition normalize_poly_i :: "'i list  'i list" where 
  "normalize_poly_i xs = smult_i (inverse (unit_factor (lead_coeff_i xs))) xs"

definition unit_factor_poly_i :: "'i list  'i list" where 
  "unit_factor_poly_i xs = cCons_i (unit_factor (lead_coeff_i xs)) []"

fun pderiv_main_i :: "'i  'i list  'i list" where
  "pderiv_main_i f (x # xs) = cCons_i (times f x) (pderiv_main_i (plus f one) xs)"
| "pderiv_main_i f [] = []"

definition pderiv_i :: "'i list  'i list" where
  "pderiv_i xs = pderiv_main_i one (tl xs)"

definition dvd_poly_i :: "'i list  'i list  bool" where
  "dvd_poly_i xs ys = ( zs. is_poly zs  ys = times_poly_i xs zs)"

definition irreducible_i :: "'i list  bool" where
  "irreducible_i xs = (degree_i xs  0 
  (q r. is_poly q  is_poly r  degree_i q < degree_i xs  degree_i r < degree_i xs 
     xs  times_poly_i q r))" 

definition poly_ops :: "'i list arith_ops_record" where
  "poly_ops  Arith_Ops_Record
      zero_poly_i
      one_poly_i 
      plus_poly_i
      times_poly_i
      minus_poly_i
      uminus_poly_i
      div_field_poly_i
      (λ _. []) ― ‹not defined›
      mod_field_poly_i
      normalize_poly_i
      unit_factor_poly_i
      (λ i. if i = 0 then [] else [arith_ops_record.of_int ops i])
      (λ _. 0) ― ‹not defined›
      is_poly"


definition gcd_poly_i :: "'i list  'i list  'i list" where
  "gcd_poly_i = arith_ops.gcd_eucl_i poly_ops"

definition euclid_ext_poly_i :: "'i list  'i list  ('i list × 'i list) × 'i list" where
  "euclid_ext_poly_i = arith_ops.euclid_ext_i poly_ops"

definition separable_i :: "'i list  bool" where
  "separable_i xs  gcd_poly_i xs (pderiv_i xs) = one_poly_i"

end

(* **************************************************************************** *)
subsubsection ‹Properties›

definition pdivmod_monic :: "'a::comm_ring_1 poly  'a poly  'a poly × 'a poly" where
  "pdivmod_monic f g  let cg = coeffs g; cf = coeffs f; 
     (q, r) = divmod_poly_one_main_list [] (rev cf) (rev cg) (1 + length cf - length cg)
         in (poly_of_list q, poly_of_list (rev r))"

lemma coeffs_smult': "coeffs (smult a p) = (if a = 0 then [] else strip_while ((=) 0) (map (Groups.times a) (coeffs p)))" 
   by (simp add: coeffs_map_poly smult_conv_map_poly)

lemma coeffs_sdiv: "coeffs (sdiv_poly p a) = (strip_while ((=) 0) (map (λ x. x div a) (coeffs p)))"
  unfolding sdiv_poly_def by (rule coeffs_map_poly)

lifting_forget poly.lifting

context ring_ops
begin

definition poly_rel :: "'i list  'a poly  bool" where
  "poly_rel x x'  list_all2 R x (coeffs x')"

lemma right_total_poly_rel[transfer_rule]: 
  "right_total poly_rel"
  using list.right_total_rel[of R] right_total unfolding poly_rel_def right_total_def by auto

lemma poly_rel_inj: "poly_rel x y  poly_rel x z  y = z" 
  using list.bi_unique_rel[OF bi_unique] unfolding poly_rel_def coeffs_eq_iff bi_unique_def by auto

lemma bi_unique_poly_rel[transfer_rule]: "bi_unique poly_rel"
  using list.bi_unique_rel[OF bi_unique] unfolding poly_rel_def bi_unique_def coeffs_eq_iff by auto

lemma Domainp_is_poly [transfer_domain_rule]: 
  "Domainp poly_rel = is_poly ops"
unfolding poly_rel_def [abs_def] is_poly_def [abs_def]
proof (intro ext iffI, unfold Domainp_iff)
  note DPR = fun_cong [OF list.Domainp_rel [of R, unfolded DPR],
    unfolded Domainp_iff]
  let ?no_trailing = "no_trailing (HOL.eq zero)"
  fix xs
  have no_trailing: "no_trailing (HOL.eq 0) xs'  ?no_trailing xs"
    if "list_all2 R xs xs'" for xs'
  proof (cases xs rule: rev_cases)
    case Nil
    with that show ?thesis
      by simp
  next
    case (snoc ys y)
    with that have "xs'  []"
      by auto
    then obtain ys' y' where "xs' = ys' @ [y']"
      by (cases xs' rule: rev_cases) simp_all
    with that snoc show ?thesis
      by simp (meson bi_unique bi_unique_def zero)
  qed
  let ?DPR = "arith_ops_record.DP ops"
  {
    assume "x'. list_all2 R xs (coeffs x')"
    then obtain xs' where *: "list_all2 R xs (coeffs xs')" by auto
    with DPR [of xs] have "list_all ?DPR xs" by auto
    then show "list_all ?DPR xs  ?no_trailing xs"
      using no_trailing [OF *] by simp
  }
  {
    assume "list_all ?DPR xs  ?no_trailing xs"
    with DPR [of xs] obtain xs' where *: "list_all2 R xs xs'" and "?no_trailing xs" 
      by auto
    from no_trailing [OF *] this(2) have "no_trailing (HOL.eq 0) xs'"
      by simp
    hence "coeffs (poly_of_list xs') = xs'" unfolding poly_of_list_impl by auto
    with * show "x'. list_all2 R xs (coeffs x')" by metis
  }
qed

(* zero *)
lemma poly_rel_zero[transfer_rule]: "poly_rel zero_poly_i 0"
  unfolding poly_rel_def by auto

(* one *)
lemma poly_rel_one[transfer_rule]: "poly_rel (one_poly_i ops) 1"
  unfolding poly_rel_def one_poly_i_def by (simp add: one)

(* cCons *)
lemma poly_rel_cCons[transfer_rule]: "(R ===> list_all2 R ===> list_all2 R) (cCons_i ops) cCons"
  unfolding cCons_i_def[abs_def] cCons_def[abs_def] 
  by transfer_prover

(* pCons *)
lemma poly_rel_pCons[transfer_rule]: "(R ===> poly_rel ===> poly_rel) (cCons_i ops) pCons"
  unfolding rel_fun_def poly_rel_def coeffs_pCons_eq_cCons cCons_def[symmetric]
  using poly_rel_cCons[unfolded rel_fun_def] by auto

(* equality *)
lemma poly_rel_eq[transfer_rule]: "(poly_rel ===> poly_rel ===> (=)) (=) (=)"
  unfolding poly_rel_def[abs_def] coeffs_eq_iff[abs_def] rel_fun_def
  by (metis bi_unique bi_uniqueDl bi_uniqueDr list.bi_unique_rel)

(* addition *)
lemma poly_rel_plus[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (plus_poly_i ops) (+)"
proof (intro rel_funI)
  fix x1 y1 x2 y2
  assume "poly_rel x1 x2" and "poly_rel y1 y2"
  thus "poly_rel (plus_poly_i ops x1 y1) (x2 + y2)"
    unfolding poly_rel_def coeffs_eq_iff coeffs_plus_eq_plus_coeffs
  proof (induct x1 y1 arbitrary: x2 y2 rule: plus_poly_i.induct)
    case (1 x1 xs1 y1 ys1 X2 Y2)
    from 1(2) obtain x2 xs2 where X2: "coeffs X2 = x2 # coeffs xs2" 
      by (cases X2, auto simp: cCons_def split: if_splits)
    from 1(3) obtain y2 ys2 where Y2: "coeffs Y2 = y2 # coeffs ys2" 
      by (cases Y2, auto simp: cCons_def split: if_splits)
    from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2" 
      and *: "list_all2 R xs1 (coeffs xs2)" "list_all2 R ys1 (coeffs ys2)" unfolding X2 Y2 by auto
    note [transfer_rule] = 1(1)[OF *] 
    show ?case unfolding X2 Y2 by simp transfer_prover
  next
    case (2 xs1 xs2 ys2)
    thus ?case by (cases "coeffs xs2", auto)
  next
    case (3 xs2 y1 ys1 Y2)
    thus ?case by (cases Y2, auto simp: cCons_def)
  qed
qed

(* unary minus *)
lemma poly_rel_uminus[transfer_rule]: "(poly_rel ===> poly_rel) (uminus_poly_i ops) Groups.uminus"
proof (intro rel_funI)
  fix x y
  assume "poly_rel x y" 
  hence [transfer_rule]: "list_all2 R x (coeffs y)" unfolding poly_rel_def .
  show "poly_rel (uminus_poly_i ops x) (-y)"
    unfolding poly_rel_def coeffs_uminus uminus_poly_i_def by transfer_prover
qed

(* subtraction *)
lemma poly_rel_minus[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (minus_poly_i ops) (-)"
proof (intro rel_funI)
  fix x1 y1 x2 y2
  assume "poly_rel x1 x2" and "poly_rel y1 y2"
  thus "poly_rel (minus_poly_i ops x1 y1) (x2 - y2)"
    unfolding diff_conv_add_uminus
    unfolding poly_rel_def coeffs_eq_iff coeffs_plus_eq_plus_coeffs coeffs_uminus
  proof (induct x1 y1 arbitrary: x2 y2 rule: minus_poly_i.induct)
    case (1 x1 xs1 y1 ys1 X2 Y2)
    from 1(2) obtain x2 xs2 where X2: "coeffs X2 = x2 # coeffs xs2" 
      by (cases X2, auto simp: cCons_def split: if_splits)
    from 1(3) obtain y2 ys2 where Y2: "coeffs Y2 = y2 # coeffs ys2" 
      by (cases Y2, auto simp: cCons_def split: if_splits)
    from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2" 
      and *: "list_all2 R xs1 (coeffs xs2)" "list_all2 R ys1 (coeffs ys2)" unfolding X2 Y2 by auto
    note [transfer_rule] = 1(1)[OF *] 
    show ?case unfolding X2 Y2 by simp transfer_prover
  next
    case (2 xs1 xs2 ys2)
    thus ?case by (cases "coeffs xs2", auto)
  next
    case (3 xs2 y1 ys1 Y2)
    from 3(1) have id0: "coeffs ys1 = coeffs 0" by (cases ys1, auto)
    have id1: "minus_poly_i ops [] (xs2 # y1) = uminus_poly_i ops (xs2 # y1)" by simp
    from 3(2) have [transfer_rule]: "poly_rel (xs2 # y1) Y2" unfolding poly_rel_def by simp
    show ?case unfolding id0 id1 coeffs_uminus[symmetric] coeffs_plus_eq_plus_coeffs[symmetric]
      poly_rel_def[symmetric] by simp transfer_prover
  qed
qed

(* smult *)
lemma poly_rel_smult[transfer_rule]: "(R ===> poly_rel ===> poly_rel) (smult_i ops) smult"
  unfolding rel_fun_def poly_rel_def coeffs_smult' smult_i_def
proof (intro allI impI, goal_cases)
  case (1 x y xs ys)
  note [transfer_rule] = 1
  show ?case by transfer_prover
qed

(* coeffs *)
lemma poly_rel_coeffs[transfer_rule]: "(poly_rel ===> list_all2 R) (λ x. x) coeffs"
  unfolding rel_fun_def poly_rel_def by auto

(* poly_of_list *)  
lemma poly_rel_poly_of_list[transfer_rule]: "(list_all2 R ===> poly_rel) (poly_of_list_i ops) poly_of_list"
  unfolding rel_fun_def poly_of_list_i_def poly_rel_def poly_of_list_impl
proof (intro allI impI, goal_cases)
  case (1 x y)
  note [transfer_rule] = this
  show ?case by transfer_prover
qed

lemma poly_rel_monom_mult[transfer_rule]: 
  "((=) ===> poly_rel ===> poly_rel) (monom_mult_i ops) monom_mult" 
  unfolding rel_fun_def monom_mult_i_def poly_rel_def monom_mult_code Let_def
proof (auto, goal_cases)
  case (1 x xs y)
  show ?case by (induct x, auto simp: 1(3) zero)
qed

declare karatsuba_main_i.simps[simp del]

lemma list_rel_coeffs_minus_i: assumes "list_all2 R x1 x2" "list_all2 R y1 y2" 
  shows "list_all2 R (coeffs_minus_i ops x1 y1) (coeffs_minus x2 y2)" 
proof -
  note simps = coeffs_minus_i.simps coeffs_minus.simps
  show ?thesis using assms
  proof (induct x1 y1 arbitrary: x2 y2 rule: coeffs_minus_i.induct)
    case (1 x xs y ys)
    from 1(2-) obtain Y Ys where y2: "y2 = Y # Ys" unfolding list_all2_conv_all_nth by (cases y2, auto)
    with 1(2-) have y: "R y Y" "list_all2 R ys Ys" by auto
    from 1(2-) obtain X Xs where x2: "x2 = X # Xs" unfolding list_all2_conv_all_nth by (cases x2, auto)
    with 1(2-) have x: "R x X" "list_all2 R xs Xs" by auto
    from 1(1)[OF x(2) y(2)] x(1) y(1)
    show ?case unfolding x2 y2 simps using minus[unfolded rel_fun_def] by auto
  next
    case (3 y ys)
    from 3 have x2: "x2 = []" by auto
    from 3 obtain Y Ys where y2: "y2 = Y # Ys" unfolding list_all2_conv_all_nth by (cases y2, auto)
    obtain y1 where y1: "y # ys = y1" by auto
    show ?case unfolding y2 simps x2 unfolding y2[symmetric] list_all2_map2 list_all2_map1
      using 3(2) unfolding y1 using uminus[unfolded rel_fun_def]
      unfolding list_all2_conv_all_nth by auto
  qed auto
qed  

(* multiplication *)
lemma poly_rel_karatsuba_main: "list_all2 R x1 x2  list_all2 R y1 y2 
  poly_rel (karatsuba_main_i ops x1 n y1 m) (karatsuba_main x2 n y2 m)"
proof (induct n arbitrary: x1 y1 x2 y2 m rule: less_induct)
  case (less n f g F G m)
  note simp[simp] = karatsuba_main.simps[of F n G m] karatsuba_main_i.simps[of ops f n g m] 
  note IH = less(1)
  note rel[transfer_rule] = less(2-3)
  show ?case (is "poly_rel ?lhs ?rhs")
  proof (cases "(n  karatsuba_lower_bound  m  karatsuba_lower_bound) = False")
    case False
    from False 
    have lhs: "?lhs = foldr (λa p. plus_poly_i ops (smult_i ops a (poly_of_list_i ops f))
         (cCons_i ops zero p)) g []" by simp
    from False have rhs: "?rhs = foldr (λa p. smult a (poly_of_list F) + pCons 0 p) G 0" by simp
    show ?thesis unfolding lhs rhs by transfer_prover
  next
    case True note * = this
    let ?n2 = "n div 2" 
    have "?n2 < n" "n - ?n2 < n" using True unfolding karatsuba_lower_bound_def by auto
    note IH = IH[OF this(1)] IH[OF this(2)]
    obtain f1 f0 where f: "split_at ?n2 f = (f0,f1)" by force
    obtain g1 g0 where g: "split_at ?n2 g = (g0,g1)" by force
    obtain F1 F0 where F: "split_at ?n2 F = (F0,F1)" by force
    obtain G1 G0 where G: "split_at ?n2 G = (G0,G1)" by force
    from rel f F have relf[transfer_rule]: "list_all2 R f0 F0" "list_all2 R f1 F1" 
      unfolding split_at_def by auto
    from rel g G have relg[transfer_rule]: "list_all2 R g0 G0" "list_all2 R g1 G1" 
      unfolding split_at_def by auto
    show ?thesis
    proof (cases "?n2 < m")
      case True
      obtain p1 P1 where p1: "p1 = karatsuba_main_i ops f1 (n - n div 2) g1 (m - n div 2)" 
          "P1 = karatsuba_main F1 (n - n div 2) G1 (m - n div 2)" by auto
      obtain p2 P2 where p2: "p2 = karatsuba_main_i ops (coeffs_minus_i ops f1 f0) (n div 2)
                          (coeffs_minus_i ops g1 g0) (n div 2)" 
          "P2 = karatsuba_main (coeffs_minus F1 F0) (n div 2)
                          (coeffs_minus G1 G0) (n div 2)" by auto 
      obtain p3 P3 where p3: "p3 = karatsuba_main_i ops f0 (n div 2) g0 (n div 2)"
          "P3 = karatsuba_main F0 (n div 2) G0 (n div 2)" by auto
      from * True have lhs: "?lhs = plus_poly_i ops (monom_mult_i ops (n div 2 + n div 2) p1)
                (plus_poly_i ops
                  (monom_mult_i ops (n div 2)
                    (plus_poly_i ops (minus_poly_i ops p1 p2) p3)) p3)" 
        unfolding simp Let_def f g split p1 p2 p3 by auto
      have [transfer_rule]: "poly_rel p1 P1" using IH(2)[OF relf(2) relg(2)] unfolding p1 .
      have [transfer_rule]: "poly_rel p3 P3" using IH(1)[OF relf(1) relg(1)] unfolding p3 .
      have [transfer_rule]: "poly_rel p2 P2" unfolding p2 
        by (rule IH(1)[OF list_rel_coeffs_minus_i list_rel_coeffs_minus_i], insert relf relg)
      from True * have rhs: "?rhs = monom_mult (n div 2 + n div 2) P1 +
               (monom_mult (n div 2) (P1 - P2 + P3) + P3)" 
        unfolding simp Let_def F G split p1 p2 p3 by auto
      show ?thesis unfolding lhs rhs by transfer_prover 
    next
      case False
      obtain p1 P1 where p1: "p1 = karatsuba_main_i ops f1 (n - n div 2) g m" 
          "P1 = karatsuba_main F1 (n - n div 2) G m" by auto 
      obtain p2 P2 where p2: "p2 = karatsuba_main_i ops f0 (n div 2) g m" 
          "P2 = karatsuba_main F0 (n div 2) G m" by auto
      from * False have lhs: "?lhs = plus_poly_i ops (monom_mult_i ops (n div 2) p1) p2" 
        unfolding simp Let_def f split p1 p2 by auto
      from * False have rhs: "?rhs = monom_mult (n div 2) P1 + P2" 
        unfolding simp Let_def F split p1 p2 by auto
      have [transfer_rule]: "poly_rel p1 P1" using IH(2)[OF relf(2) rel(2)] unfolding p1 .
      have [transfer_rule]: "poly_rel p2 P2" using IH(1)[OF relf(1) rel(2)] unfolding p2 .
      show ?thesis unfolding lhs rhs by transfer_prover 
    qed
  qed
qed
  

lemma poly_rel_times[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (times_poly_i ops) ((*))"  
proof (intro rel_funI)
  fix x1 y1 x2 y2
  assume x12[transfer_rule]: "poly_rel x1 x2" and y12 [transfer_rule]: "poly_rel y1 y2"
  hence X12[transfer_rule]: "list_all2 R x1 (coeffs x2)" and Y12[transfer_rule]: "list_all2 R y1 (coeffs y2)" 
    unfolding poly_rel_def by auto
  hence len: "length (coeffs x2) = length x1" "length (coeffs y2) = length y1" 
    unfolding list_all2_conv_all_nth by auto
  let ?cond1 = "length x1  karatsuba_lower_bound  length y1  karatsuba_lower_bound" 
  let ?cond2 = "length x1  length y1" 
  note d = karatsuba_mult_poly[symmetric] karatsuba_mult_poly_def Let_def
      times_poly_i_def len if_True if_False
  consider (TT) "?cond1 = True" "?cond2 = True" | (TF) "?cond1 = True" "?cond2 = False" 
      | (FT) "?cond1 = False" "?cond2 = True" | (FF) "?cond1 = False" "?cond2 = False" by auto
  thus "poly_rel (times_poly_i ops x1 y1) (x2 * y2)"
  proof (cases)
    case TT
    show ?thesis unfolding d TT 
      unfolding poly_rel_def coeffs_eq_iff times_poly_def times_poly_i_def fold_coeffs_def
      by transfer_prover
  next
    case TF
    show ?thesis unfolding d TF
      unfolding poly_rel_def coeffs_eq_iff times_poly_def times_poly_i_def fold_coeffs_def
      by transfer_prover
  next
    case FT
    show ?thesis unfolding d FT
      by (rule poly_rel_karatsuba_main[OF Y12 X12])
  next
    case FF
    show ?thesis unfolding d FF
      by (rule poly_rel_karatsuba_main[OF X12 Y12])
  qed
qed

(* coeff *)  
lemma poly_rel_coeff[transfer_rule]: "(poly_rel ===> (=) ===> R) (coeff_i ops) coeff"
  unfolding poly_rel_def rel_fun_def coeff_i_def nth_default_coeffs_eq[symmetric]
proof (intro allI impI, clarify)
  fix x y n
  assume [transfer_rule]: "list_all2 R x (coeffs y)"
  show "R (nth_default zero x n) (nth_default 0 (coeffs y) n)" by transfer_prover
qed

(* degree *)
lemma poly_rel_degree[transfer_rule]: "(poly_rel ===> (=)) degree_i degree"
  unfolding poly_rel_def rel_fun_def degree_i_def degree_eq_length_coeffs 
  by (simp add: list_all2_lengthD)

(* lead_coeff *)
lemma lead_coeff_i_def': "lead_coeff_i ops x = (coeff_i ops) x (degree_i x)"
  unfolding lead_coeff_i_def degree_i_def coeff_i_def
proof (cases x, auto, goal_cases)
  case (1 a xs)
  hence id: "last xs = last (a # xs)" by auto
  show ?case unfolding id by (subst last_conv_nth_default, auto)
qed

lemma poly_rel_lead_coeff[transfer_rule]: "(poly_rel ===> R) (lead_coeff_i ops) lead_coeff"
  unfolding lead_coeff_i_def' [abs_def] by transfer_prover

(* minus_poly_rev_list *)
lemma poly_rel_minus_poly_rev_list[transfer_rule]: 
  "(list_all2 R ===> list_all2 R ===> list_all2 R) (minus_poly_rev_list_i ops) minus_poly_rev_list"
proof (intro rel_funI, goal_cases)
  case (1 x1 x2 y1 y2)
  thus ?case
  proof (induct x1 y1 arbitrary: x2 y2 rule: minus_poly_rev_list_i.induct)
    case (1 x1 xs1 y1 ys1 X2 Y2)
    from 1(2) obtain x2 xs2 where X2: "X2 = x2 # xs2" by (cases X2, auto)
    from 1(3) obtain y2 ys2 where Y2: "Y2 = y2 # ys2" by (cases Y2, auto)
    from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2" 
      and *: "list_all2 R xs1 xs2" "list_all2 R ys1 ys2" unfolding X2 Y2 by auto
    note [transfer_rule] = 1(1)[OF *] 
    show ?case unfolding X2 Y2 by (simp, intro conjI, transfer_prover+)
  next
    case (2 xs1 xs2 ys2)
    thus ?case by (cases xs2, auto)
  next
    case (3 xs2 y1 ys1 Y2)
    thus ?case by (cases Y2, auto)
  qed
qed

(* division *)
lemma divmod_poly_one_main_i: assumes len: "n  length Y" and rel: "list_all2 R x X" "list_all2 R y Y"
    "list_all2 R z Z" and n: "n = N"
 shows "rel_prod (list_all2 R) (list_all2 R) (divmod_poly_one_main_i ops x y z n)
    (divmod_poly_one_main_list X Y Z N)"
   using len rel unfolding n 
proof (induct N arbitrary: x X y Y z Z)
  case (Suc n x X y Y z Z)
  from Suc(2,4) have [transfer_rule]: "R (hd y) (hd Y)" by (cases y; cases Y, auto)  
  note [transfer_rule] = Suc(3-5)
  have id: "?case = (rel_prod (list_all2 R) (list_all2 R)
     (divmod_poly_one_main_i ops (cCons_i ops (hd y) x)
       (tl (if hd y = zero then y else minus_poly_rev_list_i ops y (map (times (hd y)) z))) z n)
     (divmod_poly_one_main_list (cCons (hd Y) X)
       (tl (if hd Y = 0 then Y else minus_poly_rev_list Y (map ((*) (hd Y)) Z))) Z n))"
     by (simp add: Let_def)
  show ?case unfolding id
  proof (rule Suc(1), goal_cases)
    case 1
    show ?case using Suc(2) by simp 
  qed (transfer_prover+)
qed simp

(* modulo *)
lemma mod_poly_one_main_i: assumes len: "n  length X" and rel: "list_all2 R x X" "list_all2 R y Y"
    and n: "n = N"
 shows "list_all2 R (mod_poly_one_main_i ops x y n)
    (mod_poly_one_main_list X Y N)"
   using len rel unfolding n 
proof (induct N arbitrary: x X y Y)
  case (Suc n y Y z Z)
  from Suc(2,3) have [transfer_rule]: "R (hd y) (hd Y)" by (cases y; cases Y, auto)  
  note [transfer_rule] = Suc(3-4)
  have id: "?case = (list_all2 R
     (mod_poly_one_main_i ops
       (tl (if hd y = zero then y else minus_poly_rev_list_i ops y (map (times (hd y)) z))) z n)
     (mod_poly_one_main_list 
       (tl (if hd Y = 0 then Y else minus_poly_rev_list Y (map ((*) (hd Y)) Z))) Z n))"
     by (simp add: Let_def)
  show ?case unfolding id
  proof (rule Suc(1), goal_cases)
    case 1
    show ?case using Suc(2) by simp 
  qed (transfer_prover+)
qed simp

lemma poly_rel_dvd[transfer_rule]: "(poly_rel ===> poly_rel ===> (=)) (dvd_poly_i ops) (dvd)"
  unfolding dvd_poly_i_def[abs_def] dvd_def[abs_def] 
  by (transfer_prover_start, transfer_step+, auto)

lemma poly_rel_monic[transfer_rule]: "(poly_rel ===> (=)) (monic_i ops) monic"
  unfolding monic_i_def lead_coeff_i_def' by transfer_prover

lemma poly_rel_pdivmod_monic: assumes mon: "monic Y" 
  and x: "poly_rel x X" and y: "poly_rel y Y"
  shows "rel_prod poly_rel poly_rel (pdivmod_monic_i ops x y) (pdivmod_monic X Y)"
proof -
  note [transfer_rule] = x y
  note listall = this[unfolded poly_rel_def]
  note defs = pdivmod_monic_def pdivmod_monic_i_def Let_def
  from mon obtain k where len: "length (coeffs Y) = Suc k" unfolding poly_rel_def list_all2_iff 
      by (cases "coeffs Y", auto)
  have [transfer_rule]: 
    "rel_prod (list_all2 R) (list_all2 R)
       (divmod_poly_one_main_i ops [] (rev x) (rev y) (1 + length x - length y))
       (divmod_poly_one_main_list [] (rev (coeffs X)) (rev (coeffs Y)) (1 + length (coeffs X) - length (coeffs Y)))" 
    by (rule divmod_poly_one_main_i, insert x y listall, auto, auto simp: poly_rel_def list_all2_iff len)
  show ?thesis unfolding defs by transfer_prover
qed

lemma ring_ops_poly: "ring_ops (poly_ops ops) poly_rel"
  by (unfold_locales, auto simp: poly_ops_def  
  bi_unique_poly_rel 
  right_total_poly_rel
  poly_rel_times
  poly_rel_zero 
  poly_rel_one
  poly_rel_minus
  poly_rel_uminus
  poly_rel_plus
  poly_rel_eq
  Domainp_is_poly)
end

context idom_ops
begin

(* pderiv *)
lemma poly_rel_pderiv [transfer_rule]: "(poly_rel ===> poly_rel) (pderiv_i ops) pderiv"
proof (intro rel_funI, unfold poly_rel_def coeffs_pderiv_code pderiv_i_def pderiv_coeffs_def)
  fix xs xs'
  assume "list_all2 R xs (coeffs xs')"
  then obtain ys ys' y y' where id: "tl xs = ys" "tl (coeffs xs') = ys'" "one = y" "1 = y'" and 
    R: "list_all2 R ys ys'" "R y y'"
    by (cases xs; cases "coeffs xs'"; auto simp: one)
  show "list_all2 R (pderiv_main_i ops one (tl xs))
            (pderiv_coeffs_code 1 (tl (coeffs xs')))"
    unfolding id using R
  proof (induct ys ys' arbitrary: y y' rule: list_all2_induct)
    case (Cons x xs x' xs' y y')
    note [transfer_rule] = Cons(1,2,4)
    have "R (plus y one) (y' + 1)"  by transfer_prover
    note [transfer_rule] = Cons(3)[OF this]
    show ?case by (simp, transfer_prover)
  qed simp
qed 

lemma poly_rel_irreducible[transfer_rule]: "(poly_rel ===> (=)) (irreducible_i ops) irreducibled"
  unfolding irreducible_i_def[abs_def] irreducibled_def[abs_def] 
  by (transfer_prover_start, transfer_step+, auto)

lemma idom_ops_poly: "idom_ops (poly_ops ops) poly_rel"
  using ring_ops_poly unfolding ring_ops_def idom_ops_def by auto
end

context idom_divide_ops
begin
(* sdiv *)
lemma poly_rel_sdiv[transfer_rule]: "(poly_rel ===> R ===> poly_rel) (sdiv_i ops) sdiv_poly"
  unfolding rel_fun_def poly_rel_def coeffs_sdiv sdiv_i_def
proof (intro allI impI, goal_cases)
  case (1 x y xs ys)
  note [transfer_rule] = 1
  show ?case by transfer_prover
qed
end

context field_ops
begin
(* division *)
lemma poly_rel_div[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) 
  (div_field_poly_i ops) (div)"
proof (intro rel_funI, goal_cases)
  case (1 x X y Y)
  note [transfer_rule] = this
  note listall = this[unfolded poly_rel_def]
  note defs = div_field_poly_impl div_field_poly_impl_def div_field_poly_i_def Let_def
  show ?case 
  proof (cases "y = []")
    case True
    with 1(2) have nil: "coeffs Y = []" unfolding poly_rel_def by auto
    show ?thesis unfolding defs True nil poly_rel_def by auto
  next
    case False
    from append_butlast_last_id[OF False] obtain ys yl where y: "y = ys @ [yl]" by metis
    from False listall have "coeffs Y  []" by auto
    from append_butlast_last_id[OF this] obtain Ys Yl where Y: "coeffs Y = Ys @ [Yl]" by metis
    from listall have [transfer_rule]: "R yl Yl" by (simp add: y Y)
    have id: "last (coeffs Y) = Yl" "last (y) = yl" 
      " t e. (if y = [] then t else e) = e"
      " t e. (if coeffs Y = [] then t else e) = e" unfolding y Y by auto
    have [transfer_rule]: "(rel_prod (list_all2 R) (list_all2 R)) 
      (divmod_poly_one_main_i ops [] (rev x) (rev (map (times (inverse yl)) y))
        (1 + length x - length y))
      (divmod_poly_one_main_list [] (rev (coeffs X))
                (rev (map ((*) (Fields.inverse Yl)) (coeffs Y)))
                (1 + length (coeffs X) - length (coeffs Y)))"
    proof (rule divmod_poly_one_main_i, goal_cases)
      case 5
      from listall show ?case by (simp add: list_all2_lengthD)
    next
      case 1
      from listall show ?case by (simp add: list_all2_lengthD Y)
    qed transfer_prover+      
    show ?thesis unfolding defs id by transfer_prover
  qed
qed

(* modulo *)
lemma poly_rel_mod[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) 
  (mod_field_poly_i ops) (mod)"
proof (intro rel_funI, goal_cases)
  case (1 x X y Y)
  note [transfer_rule] = this
  note listall = this[unfolded poly_rel_def]
  note defs = mod_poly_code mod_field_poly_i_def Let_def
  show ?case 
  proof (cases "y = []")
    case True
    with 1(2) have nil: "coeffs Y = []" unfolding poly_rel_def by auto
    show ?thesis unfolding defs True nil poly_rel_def by (simp add: listall)
  next
    case False
    from append_butlast_last_id[OF False] obtain ys yl where y: "y = ys @ [yl]" by metis
    from False listall have "coeffs Y  []" by auto
    from append_butlast_last_id[OF this] obtain Ys Yl where Y: "coeffs Y = Ys @ [Yl]" by metis
    from listall have [transfer_rule]: "R yl Yl" by (simp add: y Y)
    have id: "last (coeffs Y) = Yl" "last (y) = yl" 
      " t e. (if y = [] then t else e) = e"
      " t e. (if coeffs Y = [] then t else e) = e" unfolding y Y by auto
    have [transfer_rule]: "list_all2 R
      (mod_poly_one_main_i ops (rev x) (rev (map (times (inverse yl)) y))
        (1 + length x - length y))
      (mod_poly_one_main_list (rev (coeffs X))
                (rev (map ((*) (Fields.inverse Yl)) (coeffs Y)))
                (1 + length (coeffs X) - length (coeffs Y)))"
    proof (rule mod_poly_one_main_i, goal_cases)
      case 4
      from listall show ?case by (simp add: list_all2_lengthD)
    next
      case 1
      from listall show ?case by (simp add: list_all2_lengthD Y)
    qed transfer_prover+      
    show ?thesis unfolding defs id by transfer_prover
  qed
qed

(* normalize *)
lemma poly_rel_normalize [transfer_rule]: "(poly_rel ===> poly_rel) 
  (normalize_poly_i ops) Rings.normalize"
  unfolding normalize_poly_old_def normalize_poly_i_def lead_coeff_i_def'
  by transfer_prover

(* unit_factor *)
lemma poly_rel_unit_factor [transfer_rule]: "(poly_rel ===> poly_rel) 
  (unit_factor_poly_i ops) Rings.unit_factor"
  unfolding unit_factor_poly_def unit_factor_poly_i_def lead_coeff_i_def'
  unfolding monom_0 by transfer_prover

lemma idom_divide_ops_poly: "idom_divide_ops (poly_ops ops) poly_rel"
proof -
  interpret poly: idom_ops "poly_ops ops" poly_rel by (rule idom_ops_poly)
  show ?thesis
    by (unfold_locales, simp add: poly_rel_div poly_ops_def)
qed

lemma euclidean_ring_ops_poly: "euclidean_ring_ops (poly_ops ops) poly_rel"
proof -
  interpret poly: idom_ops "poly_ops ops" poly_rel by (rule idom_ops_poly)
  have id: "arith_ops_record.normalize (poly_ops ops) = normalize_poly_i ops"
    "arith_ops_record.unit_factor (poly_ops ops) = unit_factor_poly_i ops"
    unfolding poly_ops_def by simp_all
  show ?thesis
    by (unfold_locales, simp add: poly_rel_mod poly_ops_def, unfold id, 
      simp add: poly_rel_normalize, insert poly_rel_div poly_rel_unit_factor, 
      auto simp: poly_ops_def)
qed

(* gcd poly *)
lemma poly_rel_gcd [transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (gcd_poly_i ops) gcd"
proof -
  interpret poly: euclidean_ring_ops "poly_ops ops" poly_rel by (rule euclidean_ring_ops_poly)
  show ?thesis using poly.gcd_eucl_i unfolding gcd_poly_i_def gcd_eucl .
qed

(* euclid_ext poly *)
lemma poly_rel_euclid_ext [transfer_rule]: "(poly_rel ===> poly_rel ===> 
  rel_prod (rel_prod poly_rel poly_rel) poly_rel) (euclid_ext_poly_i ops) euclid_ext"
proof -
  interpret poly: euclidean_ring_ops "poly_ops ops" poly_rel by (rule euclidean_ring_ops_poly)
  show ?thesis using poly.euclid_ext_i unfolding euclid_ext_poly_i_def .
qed 

end

(* ********************************************************** *)

context ring_ops
begin
notepad (* checking transfer rules *)
begin
  fix xs x ys y
  assume [transfer_rule]: "poly_rel xs x" "poly_rel ys y" 
  have "x * y = y * x" by simp
  from this[untransferred]
  have "times_poly_i ops xs ys = times_poly_i ops ys xs" .
end
end
end

Theory Poly_Mod_Finite_Field_Record_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsubsection ‹Over a Finite Field›
theory Poly_Mod_Finite_Field_Record_Based
imports
  Poly_Mod_Finite_Field
  Finite_Field_Record_Based
  Polynomial_Record_Based
begin

locale arith_ops_record = arith_ops ops + poly_mod m for ops :: "'i arith_ops_record" and m :: int
begin
definition M_rel_i :: "'i  int  bool" where 
  "M_rel_i f F = (arith_ops_record.to_int ops f = M F)" 

definition Mp_rel_i :: "'i list  int poly  bool" where 
  "Mp_rel_i f F = (map (arith_ops_record.to_int ops) f = coeffs (Mp F))" 

lemma Mp_rel_i_Mp[simp]: "Mp_rel_i f (Mp F) = Mp_rel_i f F" unfolding Mp_rel_i_def by auto

lemma Mp_rel_i_Mp_to_int_poly_i: "Mp_rel_i f F  Mp (to_int_poly_i ops f) = to_int_poly_i ops f" 
  unfolding Mp_rel_i_def to_int_poly_i_def by simp
end

locale mod_ring_gen = ring_ops ff_ops R for ff_ops :: "'i arith_ops_record" and
  R :: "'i  'a :: nontriv mod_ring  bool" +
  fixes p :: int 
  assumes p: "p = int CARD('a)"
  and of_int: "0  x  x < p  R (arith_ops_record.of_int ff_ops x) (of_int x)" 
  and to_int: "R y z  arith_ops_record.to_int ff_ops y = to_int_mod_ring z" 
  and to_int': "0  arith_ops_record.to_int ff_ops y  arith_ops_record.to_int ff_ops y < p  
    R y (of_int (arith_ops_record.to_int ff_ops y))" 
begin

lemma nat_p: "nat p = CARD('a)" unfolding p by simp

sublocale poly_mod_type p "TYPE('a)"
  by (unfold_locales, rule p)

lemma coeffs_to_int_poly: "coeffs (to_int_poly (x :: 'a mod_ring poly)) = map to_int_mod_ring (coeffs x)" 
  by (rule coeffs_map_poly, auto)

lemma coeffs_of_int_poly: "coeffs (of_int_poly (Mp x) :: 'a mod_ring poly) = map of_int (coeffs (Mp x))"
  apply (rule coeffs_map_poly)
  by (metis M_0 M_M Mp_coeff leading_coeff_0_iff of_int_hom.hom_zero to_int_mod_ring_of_int_M)

lemma to_int_poly_i: assumes "poly_rel f g" shows "to_int_poly_i ff_ops f = to_int_poly g"
proof -
  have *: "map (arith_ops_record.to_int ff_ops) f = coeffs (to_int_poly g)"
    unfolding coeffs_to_int_poly 
    by (rule nth_equalityI, insert assms, auto simp: list_all2_conv_all_nth poly_rel_def to_int)
  show ?thesis unfolding coeffs_eq_iff to_int_poly_i_def poly_of_list_def coeffs_Poly *
    strip_while_coeffs..
qed

lemma poly_rel_of_int_poly: assumes id: "f' = of_int_poly_i ff_ops (Mp f)" "f'' = of_int_poly (Mp f)" 
  shows "poly_rel f' f''" unfolding id poly_rel_def
  unfolding list_all2_conv_all_nth coeffs_of_int_poly of_int_poly_i_def length_map
  by (rule conjI[OF refl], intro allI impI, simp add: nth_coeffs_coeff Mp_coeff M_def, rule of_int,
    insert p, auto)

sublocale arith_ops_record ff_ops p .

lemma Mp_rel_iI: "poly_rel f1 f2  MP_Rel f3 f2  Mp_rel_i f1 f3" 
  unfolding Mp_rel_i_def MP_Rel_def poly_rel_def
  by (auto simp add: list_all2_conv_all_nth to_int intro: nth_equalityI)

lemma M_rel_iI: "R f1 f2  M_Rel f3 f2  M_rel_i f1 f3" 
  unfolding M_rel_i_def M_Rel_def by (simp add: to_int)

lemma M_rel_iI': assumes "R f1 f2" 
  shows "M_rel_i f1 (arith_ops_record.to_int ff_ops f1)" 
  by (rule M_rel_iI[OF assms], simp add: to_int[OF assms] M_Rel_def M_to_int_mod_ring)

lemma Mp_rel_iI': assumes "poly_rel f1 f2" 
  shows "Mp_rel_i f1 (to_int_poly_i ff_ops f1)" 
proof (rule Mp_rel_iI[OF assms], unfold to_int_poly_i[OF assms]) 
  show "MP_Rel (to_int_poly f2) f2" unfolding MP_Rel_def by (simp add: Mp_to_int_poly)
qed

lemma M_rel_iD: assumes "M_rel_i f1 f3"
  shows 
    "R f1 (of_int (M f3))"
    "M_Rel f3 (of_int (M f3))"  
proof -
  show "M_Rel f3 (of_int (M f3))"
    using M_Rel_def to_int_mod_ring_of_int_M by auto
  from assms show "R f1 (of_int (M f3))" 
    unfolding M_rel_i_def
    by (metis int_one_le_iff_zero_less leD linear m1 poly_mod.M_def pos_mod_conj to_int')
qed

lemma Mp_rel_iD: assumes "Mp_rel_i f1 f3"
  shows 
    "poly_rel f1 (of_int_poly (Mp f3))"
    "MP_Rel f3 (of_int_poly (Mp f3))"  
proof -
  show Rel: "MP_Rel f3 (of_int_poly (Mp f3))"
    using MP_Rel_def Mp_Mp Mp_f_representative by auto
  let ?ti = "arith_ops_record.to_int ff_ops" 
  from assms[unfolded Mp_rel_i_def] have
    *: "coeffs (Mp f3) = map ?ti f1" by auto
  {
    fix x
    assume "x  set f1"
    hence "?ti x  set (map ?ti f1)" by auto
    from this[folded *] have "?ti x  range M"
      by (metis (no_types, lifting) MP_Rel_def M_to_int_mod_ring Rel coeffs_to_int_poly ex_map_conv range_eqI)    
    hence "?ti x  0" "?ti x < p" unfolding M_def using m1 by auto
    hence "R x (of_int (?ti x))"
      by (rule to_int')
  }
  thus "poly_rel f1 (of_int_poly (Mp f3))" using *
    unfolding poly_rel_def coeffs_of_int_poly
    by (auto simp: list_all2_map2 list_all2_same)
qed
end

locale prime_field_gen = field_ops ff_ops R + mod_ring_gen ff_ops R p for ff_ops :: "'i arith_ops_record" and
  R :: "'i  'a :: prime_card mod_ring  bool" and p :: int
begin

sublocale poly_mod_prime_type p "TYPE('a)"
  by (unfold_locales, rule p)

end

lemma (in mod_ring_locale) mod_ring_rel_of_int: 
  "0  x  x < p  mod_ring_rel x (of_int x)" 
  unfolding mod_ring_rel_def
  by (transfer, auto simp: p)

context prime_field
begin


lemma prime_field_finite_field_ops_int: "prime_field_gen (finite_field_ops_int p) mod_ring_rel p" 
proof -
  interpret field_ops "finite_field_ops_int p" mod_ring_rel by (rule finite_field_ops_int)
  show ?thesis
    by (unfold_locales, rule p, 
    auto simp: finite_field_ops_int_def p mod_ring_rel_def of_int_of_int_mod_ring)
qed

lemma prime_field_finite_field_ops_integer: "prime_field_gen (finite_field_ops_integer (integer_of_int p)) mod_ring_rel_integer p" 
proof -
  interpret field_ops "finite_field_ops_integer (integer_of_int p)" mod_ring_rel_integer by (rule finite_field_ops_integer, simp)
  have pp: "p = int_of_integer (integer_of_int p)" by auto
  interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
    by (rule prime_field_finite_field_ops_int)
  show ?thesis
    by (unfold_locales, rule p, auto simp: finite_field_ops_integer_def 
      mod_ring_rel_integer_def[OF pp] urel_integer_def[OF pp] mod_ring_rel_of_int
      int.to_int[symmetric] finite_field_ops_int_def) 
qed

lemma prime_field_finite_field_ops32: assumes small: "p  65535" 
  shows "prime_field_gen (finite_field_ops32 (uint32_of_int p)) mod_ring_rel32 p" 
proof -
  let ?pp = "uint32_of_int p" 
  have ppp: "p = int_of_uint32 ?pp"
    by (subst int_of_uint32_inv, insert small p2, auto)
  note * = ppp small 
  interpret field_ops "finite_field_ops32 ?pp" mod_ring_rel32 
    by (rule finite_field_ops32, insert *)
  interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
    by (rule prime_field_finite_field_ops_int)
  show ?thesis
  proof (unfold_locales, rule p, auto simp: finite_field_ops32_def)
    fix x
    assume x: "0  x" "x < p" 
    from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
    thus "mod_ring_rel32 (uint32_of_int x) (of_int x)" unfolding mod_ring_rel32_def[OF *]
      by (intro exI[of _ x], auto simp: urel32_def[OF *], subst int_of_uint32_inv, insert * x, auto)
  next
    fix y z
    assume "mod_ring_rel32 y z" 
    from this[unfolded mod_ring_rel32_def[OF *]] obtain x where yx: "urel32 y x" and xz: "mod_ring_rel x z" by auto
    from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
    show "int_of_uint32 y = to_int_mod_ring z" unfolding zx using yx unfolding urel32_def[OF *] by simp
  next
    fix y
    show "0  int_of_uint32 y  int_of_uint32 y < p  mod_ring_rel32 y (of_int (int_of_uint32 y))"
      unfolding mod_ring_rel32_def[OF *] urel32_def[OF *]
      by (intro exI[of _ "int_of_uint32 y"], auto simp: mod_ring_rel_of_int)
  qed
qed

lemma prime_field_finite_field_ops64: assumes small: "p  4294967295" 
  shows "prime_field_gen (finite_field_ops64 (uint64_of_int p)) mod_ring_rel64 p" 
proof -
  let ?pp = "uint64_of_int p" 
  have ppp: "p = int_of_uint64 ?pp"
    by (subst int_of_uint64_inv, insert small p2, auto)
  note * = ppp small 
  interpret field_ops "finite_field_ops64 ?pp" mod_ring_rel64
    by (rule finite_field_ops64, insert *)
  interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
    by (rule prime_field_finite_field_ops_int)
  show ?thesis
  proof (unfold_locales, rule p, auto simp: finite_field_ops64_def)
    fix x
    assume x: "0  x" "x < p" 
    from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
    thus "mod_ring_rel64 (uint64_of_int x) (of_int x)" unfolding mod_ring_rel64_def[OF *]
      by (intro exI[of _ x], auto simp: urel64_def[OF *], subst int_of_uint64_inv, insert * x, auto)
  next
    fix y z
    assume "mod_ring_rel64 y z" 
    from this[unfolded mod_ring_rel64_def[OF *]] obtain x where yx: "urel64 y x" and xz: "mod_ring_rel x z" by auto
    from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
    show "int_of_uint64 y = to_int_mod_ring z" unfolding zx using yx unfolding urel64_def[OF *] by simp
  next
    fix y
    show "0  int_of_uint64 y  int_of_uint64 y < p  mod_ring_rel64 y (of_int (int_of_uint64 y))"
      unfolding mod_ring_rel64_def[OF *] urel64_def[OF *]
      by (intro exI[of _ "int_of_uint64 y"], auto simp: mod_ring_rel_of_int)
  qed
qed
end

context mod_ring_locale
begin
lemma mod_ring_finite_field_ops_int: "mod_ring_gen (finite_field_ops_int p) mod_ring_rel p" 
proof -
  interpret ring_ops "finite_field_ops_int p" mod_ring_rel by (rule ring_finite_field_ops_int)
  show ?thesis
    by (unfold_locales, rule p, 
      auto simp: finite_field_ops_int_def p mod_ring_rel_def of_int_of_int_mod_ring)
qed

lemma mod_ring_finite_field_ops_integer: "mod_ring_gen (finite_field_ops_integer (integer_of_int p)) mod_ring_rel_integer p" 
proof -
  interpret ring_ops "finite_field_ops_integer (integer_of_int p)" mod_ring_rel_integer by (rule ring_finite_field_ops_integer, simp)
  have pp: "p = int_of_integer (integer_of_int p)" by auto
  interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
    by (rule mod_ring_finite_field_ops_int)
  show ?thesis
    by (unfold_locales, rule p, auto simp: finite_field_ops_integer_def 
      mod_ring_rel_integer_def[OF pp] urel_integer_def[OF pp] mod_ring_rel_of_int
      int.to_int[symmetric] finite_field_ops_int_def) 
qed


lemma mod_ring_finite_field_ops32: assumes small: "p  65535" 
  shows "mod_ring_gen (finite_field_ops32 (uint32_of_int p)) mod_ring_rel32 p" 
proof -
  let ?pp = "uint32_of_int p" 
  have ppp: "p = int_of_uint32 ?pp"
    by (subst int_of_uint32_inv, insert small p2, auto)
  note * = ppp small 
  interpret ring_ops "finite_field_ops32 ?pp" mod_ring_rel32 
    by (rule ring_finite_field_ops32, insert *)
  interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
    by (rule mod_ring_finite_field_ops_int)
  show ?thesis
  proof (unfold_locales, rule p, auto simp: finite_field_ops32_def)
    fix x
    assume x: "0  x" "x < p" 
    from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
    thus "mod_ring_rel32 (uint32_of_int x) (of_int x)" unfolding mod_ring_rel32_def[OF *]
      by (intro exI[of _ x], auto simp: urel32_def[OF *], subst int_of_uint32_inv, insert * x, auto)
  next
    fix y z
    assume "mod_ring_rel32 y z" 
    from this[unfolded mod_ring_rel32_def[OF *]] obtain x where yx: "urel32 y x" and xz: "mod_ring_rel x z" by auto
    from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
    show "int_of_uint32 y = to_int_mod_ring z" unfolding zx using yx unfolding urel32_def[OF *] by simp
  next
    fix y
    show "0  int_of_uint32 y  int_of_uint32 y < p  mod_ring_rel32 y (of_int (int_of_uint32 y))"
      unfolding mod_ring_rel32_def[OF *] urel32_def[OF *]
      by (intro exI[of _ "int_of_uint32 y"], auto simp: mod_ring_rel_of_int)
  qed
qed

lemma mod_ring_finite_field_ops64: assumes small: "p  4294967295" 
  shows "mod_ring_gen (finite_field_ops64 (uint64_of_int p)) mod_ring_rel64 p" 
proof -
  let ?pp = "uint64_of_int p" 
  have ppp: "p = int_of_uint64 ?pp"
    by (subst int_of_uint64_inv, insert small p2, auto)
  note * = ppp small 
  interpret ring_ops "finite_field_ops64 ?pp" mod_ring_rel64 
    by (rule ring_finite_field_ops64, insert *)
  interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
    by (rule mod_ring_finite_field_ops_int)
  show ?thesis
  proof (unfold_locales, rule p, auto simp: finite_field_ops64_def)
    fix x
    assume x: "0  x" "x < p" 
    from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
    thus "mod_ring_rel64 (uint64_of_int x) (of_int x)" unfolding mod_ring_rel64_def[OF *]
      by (intro exI[of _ x], auto simp: urel64_def[OF *], subst int_of_uint64_inv, insert * x, auto)
  next
    fix y z
    assume "mod_ring_rel64 y z" 
    from this[unfolded mod_ring_rel64_def[OF *]] obtain x where yx: "urel64 y x" and xz: "mod_ring_rel x z" by auto
    from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
    show "int_of_uint64 y = to_int_mod_ring z" unfolding zx using yx unfolding urel64_def[OF *] by simp
  next
    fix y
    show "0  int_of_uint64 y  int_of_uint64 y < p  mod_ring_rel64 y (of_int (int_of_uint64 y))"
      unfolding mod_ring_rel64_def[OF *] urel64_def[OF *]
      by (intro exI[of _ "int_of_uint64 y"], auto simp: mod_ring_rel_of_int)
  qed
qed
end

end

Theory Chinese_Remainder_Poly

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Chinese Remainder Theorem for Polynomials›

text ‹We prove the Chinese Remainder Theorem, and strengthen it by showing uniqueness›

theory Chinese_Remainder_Poly
imports
  "HOL-Number_Theory.Residues"  
  Polynomial_Factorization.Polynomial_Divisibility
  Polynomial_Interpolation.Missing_Polynomial
begin

lemma cong_add_poly:
  "[(a::'b::{field_gcd} poly) = b] (mod m)  [c = d] (mod m)  [a + c = b + d] (mod m)"
  by (fact cong_add)

lemma cong_mult_poly:
  "[(a::'b::{field_gcd} poly) = b] (mod m)  [c = d] (mod m)  [a * c = b * d] (mod m)"
  by (fact cong_mult)

lemma cong_mult_self_poly: "[(a::'b::{field_gcd} poly) * m = 0] (mod m)"
  by (fact cong_mult_self_right)

lemma cong_scalar2_poly: "[(a::'b::{field_gcd} poly)= b] (mod m)  [k * a = k * b] (mod m)"
  by (fact cong_scalar_left)

lemma cong_sum_poly:
    "(x. x  A  [((f x)::'b::{field_gcd} poly) = g x] (mod m)) 
      [(xA. f x) = (xA. g x)] (mod m)"
  by (rule cong_sum)

lemma cong_iff_lin_poly: "([(a::'b::{field_gcd} poly) = b] (mod m)) = (k. b = a + m * k)"
  using cong_diff_iff_cong_0 [of b a m] by (auto simp add: cong_0_iff dvd_def algebra_simps dest: cong_sym)

lemma cong_solve_poly: "(a::'b::{field_gcd} poly)  0  x. [a * x = gcd a n] (mod n)"
proof (cases "n = 0")
  case True
  note n0=True
  show ?thesis
  proof (cases "monic a")
    case True
    have n: "normalize a = a" by (rule normalize_monic[OF True])
    show ?thesis
    by (rule exI[of _ 1], auto simp add: n0 n cong_def)
  next
    case False
    show ?thesis 
      by (auto simp add: True cong_def normalize_poly_old_def map_div_is_smult_inverse)
         (metis mult.right_neutral mult_smult_right) 
  qed
next
 case False
 note n_not_0 = False
 show ?thesis
   using bezout_coefficients_fst_snd [of a n, symmetric]
   by (auto simp add: cong_iff_lin_poly mult.commute [of a] mult.commute [of n])
qed


lemma cong_solve_coprime_poly: 
assumes coprime_an:"coprime (a::'b::{field_gcd} poly) n"
shows "x. [a * x = 1] (mod n)"
proof (cases "a = 0")
  case True
  show ?thesis unfolding cong_def
    using True coprime_an by auto
next
  case False  
  show ?thesis
    using coprime_an cong_solve_poly[OF False, of n]
    unfolding cong_def
    by presburger  
qed
  
lemma cong_dvd_modulus_poly:
  "[x = y] (mod m)  n dvd m  [x = y] (mod n)" for x y :: "'b::{field_gcd} poly"
  by (auto simp add: cong_iff_lin_poly elim!: dvdE)

lemma chinese_remainder_aux_poly:
  fixes A :: "'a set"
    and m :: "'a  'b::{field_gcd} poly"
  assumes fin: "finite A"
    and cop: "i  A. (j  A. i  j  coprime (m i) (m j))"
  shows "b. (i  A. [b i = 1] (mod m i)  [b i = 0] (mod (j  A - {i}. m j)))"
proof (rule finite_set_choice, rule fin, rule ballI)
  fix i
  assume "i : A"
  with cop have "coprime (j  A - {i}. m j) (m i)"
    by (auto intro: prod_coprime_left)
  then have "x. [(j  A - {i}. m j) * x = 1] (mod m i)"
    by (elim cong_solve_coprime_poly)
  then obtain x where "[(j  A - {i}. m j) * x = 1] (mod m i)"
    by auto
  moreover have "[(j  A - {i}. m j) * x = 0]
    (mod (j  A - {i}. m j))"
    by (subst mult.commute, rule cong_mult_self_poly)
  ultimately show "a. [a = 1] (mod m i)  [a = 0]
      (mod prod m (A - {i}))"
    by blast
qed


(*The Chinese Remainder Theorem for polynomials: *)
lemma chinese_remainder_poly:
  fixes A :: "'a set"
    and m :: "'a  'b::{field_gcd} poly"
    and u :: "'a  'b poly"
  assumes fin: "finite A"
    and cop: "iA. (jA. i  j  coprime (m i) (m j))"
  shows "x. (iA. [x = u i] (mod m i))"
proof -
  from chinese_remainder_aux_poly [OF fin cop] obtain b where
    bprop: "iA. [b i = 1] (mod m i) 
      [b i = 0] (mod (j  A - {i}. m j))"
    by blast
  let ?x = "iA. (u i) * (b i)"
  show "?thesis"
  proof (rule exI, clarify)
    fix i
    assume a: "i : A"
    show "[?x = u i] (mod m i)"
    proof -
      from fin a have "?x = (j  {i}. u j * b j) +
          (j  A - {i}. u j * b j)"
        by (subst sum.union_disjoint [symmetric], auto intro: sum.cong)
      then have "[?x = u i * b i + (j  A - {i}. u j * b j)] (mod m i)"
        unfolding cong_def
        by auto
      also have "[u i * b i + (j  A - {i}. u j * b j) =
                  u i * 1 + (j  A - {i}. u j * 0)] (mod m i)"
        apply (rule cong_add_poly)
        apply (rule cong_scalar2_poly)
        using bprop a apply blast
        apply (rule cong_sum)
        apply (rule cong_scalar2_poly)
        using bprop apply auto
        apply (rule cong_dvd_modulus_poly)
        apply (drule (1) bspec)
        apply (erule conjE)
        apply assumption
        apply rule
        using fin a apply auto
        done
       thus ?thesis
       by (metis (no_types, lifting) a add.right_neutral fin mult_cancel_left1 mult_cancel_right1 
         sum.not_neutral_contains_not_neutral sum.remove)
    qed
  qed
qed


(*********************** Now we try to prove the uniqueness **********************)

lemma cong_trans_poly:
    "[(a::'b::{field_gcd} poly) = b] (mod m)  [b = c] (mod m)  [a = c] (mod m)"
  by (fact cong_trans)

lemma cong_mod_poly: "(n::'b::{field_gcd} poly) ~= 0  [a mod n = a] (mod n)"
  by auto

lemma cong_sym_poly: "[(a::'b::{field_gcd} poly) = b] (mod m)  [b = a] (mod m)"
  by (fact cong_sym)

lemma cong_1_poly: "[(a::'b::{field_gcd} poly) = b] (mod 1)"
  by (fact cong_1)

lemma coprime_cong_mult_poly:
  assumes "[(a::'b::{field_gcd} poly) = b] (mod m)" and "[a = b] (mod n)" and "coprime m n"
  shows "[a = b] (mod m * n)"
  using divides_mult assms
  by (metis (no_types, hide_lams) cong_dvd_modulus_poly cong_iff_lin_poly dvd_mult2 dvd_refl minus_add_cancel mult.right_neutral) 

lemma coprime_cong_prod_poly:
    "(iA. (jA. i  j  coprime (m i) (m j))) 
      (iA. [(x::'b::{field_gcd} poly) = y] (mod m i)) 
         [x = y] (mod (iA. m i))"
  apply (induct A rule: infinite_finite_induct)
    apply auto
  apply (metis coprime_cong_mult_poly prod_coprime_right)
  done

lemma cong_less_modulus_unique_poly:
    "[(x::'b::{field_gcd} poly) = y] (mod m)  degree x < degree m  degree y < degree m  x = y"
    by (simp add: cong_def mod_poly_less)


lemma chinese_remainder_unique_poly:
  fixes A :: "'a set"
    and m :: "'a  'b::{field_gcd} poly"
    and u :: "'a  'b poly"
  assumes nz: "iA. (m i)  0"
    and cop: "iA. (jA. i  j  coprime (m i) (m j))"
    (*The following assumption should not be necessary, but I need it since in Isabelle 
      degree 0 is 0 instead of -∞*)
    and not_constant: "0 < degree (prod m A)" 
  shows "∃!x. degree x < (iA. degree (m i))  (iA. [x = u i] (mod m i))"
proof -
  from not_constant have fin: "finite A"
    by (metis degree_1 gr_implies_not0 prod.infinite)
  from chinese_remainder_poly [OF fin cop]
  obtain y where one: "(iA. [y = u i] (mod m i))"
    by blast
  let ?x = "y mod (iA. m i)"
  have degree_prod_sum: "degree (prod m A) = (iA. degree (m i))" 
    by (rule degree_prod_eq_sum_degree[OF nz])
  from fin nz have prodnz: "(iA. (m i))  0"
     by auto
  (*This would hold without the premise not_constant if degree 0 = -∞*)
  have less: "degree ?x < (iA. degree (m i))" 
    unfolding degree_prod_sum[symmetric]
    using degree_mod_less[OF prodnz, of y]
    using not_constant
    by auto    
  have cong: "iA. [?x = u i] (mod m i)"
    apply auto
    apply (rule cong_trans_poly)
    prefer 2
    using one apply auto
    apply (rule cong_dvd_modulus_poly)
    apply (rule cong_mod_poly)
    using prodnz apply auto
    apply rule
    apply (rule fin)
    apply assumption
    done    
  have unique: "z. degree z < (iA. degree (m i)) 
      (iA. [z = u i] (mod m i))  z = ?x"
  proof (clarify)
    fix z::"'b poly"
    assume zless: "degree z < (iA. degree (m i))"
    assume zcong: "(iA. [z = u i] (mod m i))"   
    have deg1: "degree z < degree (prod m A)"
      using degree_prod_sum zless by simp
    have deg2: "degree ?x < degree (prod m A)"
      by (metis deg1 degree_0 degree_mod_less gr0I gr_implies_not0)
    have "iA. [?x = z] (mod m i)"
      apply clarify
      apply (rule cong_trans_poly)
      using cong apply (erule bspec)
      apply (rule cong_sym_poly)
      using zcong by auto
    with fin cop have "[?x = z] (mod (iA. m i))"
      by (intro coprime_cong_prod_poly) auto
    with zless  show "z = ?x"
      apply (intro cong_less_modulus_unique_poly)
      apply (erule cong_sym_poly)
      apply (auto simp add:  deg1 deg2)
      done
  qed
  from less cong unique show ?thesis by blast
qed

end

Theory Berlekamp_Type_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹The Berlekamp Algorithm›

theory Berlekamp_Type_Based
imports
  Jordan_Normal_Form.Matrix_Kernel
  Jordan_Normal_Form.Gauss_Jordan_Elimination
  Jordan_Normal_Form.Missing_VectorSpace
  Polynomial_Factorization.Square_Free_Factorization
  Polynomial_Factorization.Missing_Multiset
  Finite_Field
  Chinese_Remainder_Poly
  Poly_Mod_Finite_Field
  "HOL-Computational_Algebra.Field_as_Ring"
begin

hide_const (open) up_ring.coeff up_ring.monom Modules.module subspace
  Modules.module_hom


subsection ‹Auxiliary lemmas›

context
  fixes g :: "'b  'a :: comm_monoid_mult"
begin
lemma prod_list_map_filter: "prod_list (map g (filter f xs)) * prod_list (map g (filter (λ x. ¬ f x) xs)) 
  = prod_list (map g xs)"
  by (induct xs, auto simp: ac_simps)

lemma prod_list_map_partition: 
  assumes "List.partition f xs = (ys, zs)"
  shows "prod_list (map g xs) = prod_list (map g ys) * prod_list (map g zs)"
  using assms  by (subst prod_list_map_filter[symmetric, of _ f], auto simp: o_def)
end

lemma coprime_id_is_unit:
  fixes a::"'b::semiring_gcd"
  shows "coprime a a  is_unit a"
  using dvd_unit_imp_unit by auto

lemma dim_vec_of_list[simp]: "dim_vec (vec_of_list x) = length x"
  by (transfer, auto)

lemma length_list_of_vec[simp]: "length (list_of_vec A) = dim_vec A"
  by (transfer', auto)

lemma list_of_vec_vec_of_list[simp]: "list_of_vec (vec_of_list a) = a"
proof -
  {
  fix aa :: "'a list"
  have "map (λn. if n < length aa then aa ! n else undef_vec (n - length aa)) [0..<length aa]
    = map ((!) aa) [0..<length aa]"
    by simp
  hence "map (λn. if n < length aa then aa ! n else undef_vec (n - length aa)) [0..<length aa] = aa"
    by (simp add: map_nth)
  }
  thus ?thesis by (transfer, simp add: mk_vec_def)
qed


context
assumes "SORT_CONSTRAINT('a::finite)"
begin

lemma inj_Poly_list_of_vec': "inj_on (Poly  list_of_vec) {v. dim_vec v = n}"
proof (rule comp_inj_on)
  show "inj_on list_of_vec {v. dim_vec v = n}"
    by (auto simp add: inj_on_def, transfer, auto simp add: mk_vec_def)
  show "inj_on Poly (list_of_vec ` {v. dim_vec v = n})"
  proof (auto simp add: inj_on_def)
    fix x y::"'c vec" assume "n = dim_vec x" and dim_xy: "dim_vec y = dim_vec x"
    and Poly_eq: "Poly (list_of_vec x) = Poly (list_of_vec y)"
    note [simp del] = nth_list_of_vec
    show "list_of_vec x = list_of_vec y"  
    proof (rule nth_equalityI, auto simp: dim_xy)
      have length_eq: "length (list_of_vec x ) = length (list_of_vec y)"
        using dim_xy by (transfer, auto)
      fix i assume "i < dim_vec x"
      thus "list_of_vec x ! i = list_of_vec y ! i" using Poly_eq unfolding poly_eq_iff coeff_Poly_eq
        using dim_xy unfolding nth_default_def by (auto, presburger)
     qed
  qed
qed

corollary inj_Poly_list_of_vec: "inj_on (Poly  list_of_vec) (carrier_vec n)"
  using inj_Poly_list_of_vec' unfolding carrier_vec_def .

lemma list_of_vec_rw_map: "list_of_vec m = map (λn. m $ n) [0..<dim_vec m]"
    by (transfer, auto simp add: mk_vec_def)

lemma degree_Poly':
assumes xs: "xs  []"
shows "degree (Poly xs) < length xs"
using xs
by (induct xs, auto intro: Poly.simps(1))

lemma vec_of_list_list_of_vec[simp]: "vec_of_list (list_of_vec a) = a"
by (transfer, auto simp add: mk_vec_def)

lemma row_mat_of_rows_list:
assumes b: "b < length A"
and nc: "i. i < length A  length (A ! i) = nc"
shows "(row (mat_of_rows_list nc A) b) = vec_of_list (A ! b)"
proof (auto simp add: vec_eq_iff)
  show "dim_col (mat_of_rows_list nc A) = length (A ! b)"
    unfolding mat_of_rows_list_def using b nc by auto
  fix i assume i: "i < length (A ! b)"
  show "row (mat_of_rows_list nc A) b $ i = vec_of_list (A ! b) $ i"
    using i b nc
    unfolding mat_of_rows_list_def row_def
    by (transfer, auto simp add: mk_vec_def mk_mat_def)
qed

lemma degree_Poly_list_of_vec:
assumes n: "x  carrier_vec n"
and n0: "n > 0"
shows "degree (Poly (list_of_vec x)) < n"
proof -
  have x_dim: "dim_vec x = n" using n by auto
  have l: "(list_of_vec x)  []"
    by (auto simp add: list_of_vec_rw_map vec_of_dim_0[symmetric] n0 n x_dim)
  have "degree (Poly (list_of_vec x)) < length (list_of_vec x)" by (rule degree_Poly'[OF l])
  also have "... = n" using x_dim by auto
  finally show ?thesis .
qed

lemma list_of_vec_nth:
  assumes i: "i < dim_vec x"
  shows "list_of_vec x ! i = x $ i"
  using i
  by (transfer, auto simp add: mk_vec_def)

lemma coeff_Poly_list_of_vec_nth':
 assumes i: "i < dim_vec x"
 shows "coeff (Poly (list_of_vec x)) i = x $ i"
 using i
 by (auto simp add: list_of_vec_nth nth_default_def)

lemma list_of_vec_row_nth:
assumes x: "x < dim_col A"
shows "list_of_vec (row A i) ! x = A $$ (i, x)"
using x unfolding row_def by (transfer', auto simp add: mk_vec_def)

lemma coeff_Poly_list_of_vec_nth:
assumes x: "x < dim_col A"
shows "coeff (Poly (list_of_vec (row A i))) x = A $$ (i, x)"
proof -
  have "coeff (Poly (list_of_vec (row A i))) x  = nth_default 0 (list_of_vec (row A i)) x"
    unfolding coeff_Poly_eq  by simp
  also have "... = A $$ (i, x)" using x list_of_vec_row_nth
    unfolding nth_default_def by (auto simp del: nth_list_of_vec)
  finally show ?thesis .
qed

lemma inj_on_list_of_vec: "inj_on list_of_vec (carrier_vec n)"
 unfolding inj_on_def unfolding list_of_vec_rw_map by auto

lemma vec_of_list_carrier[simp]: "vec_of_list x  carrier_vec (length x)"
  unfolding carrier_vec_def by simp

lemma card_carrier_vec: "card (carrier_vec n:: 'b::finite vec set) = CARD('b) ^ n"
proof -
  let ?A = "UNIV::'b set"
  let ?B = "{xs. set xs  ?A  length xs = n}"
  let ?C = "(carrier_vec n:: 'b::finite vec set)"
  have "card ?C = card ?B"
  proof -
    have "bij_betw (list_of_vec) ?C ?B"
    proof (unfold bij_betw_def, auto)
      show "inj_on list_of_vec (carrier_vec n)" by (rule inj_on_list_of_vec)
      fix x::"'b list"
      assume n: "n = length x"
      thus "x  list_of_vec ` carrier_vec (length x)"
        unfolding image_def
        by auto (rule bexI[of _ "vec_of_list x"], auto)
    qed
    thus ?thesis using bij_betw_same_card by blast
  qed
  also have "... = card ?A ^ n"
    by (rule card_lists_length_eq, simp)
  finally show ?thesis .
qed


lemma finite_carrier_vec[simp]: "finite (carrier_vec n:: 'b::finite vec set)"
  by (rule card_ge_0_finite, unfold card_carrier_vec, auto)


lemma row_echelon_form_dim0_row:
assumes "A  carrier_mat 0 n"
shows "row_echelon_form A"
using assms
unfolding row_echelon_form_def pivot_fun_def Let_def by auto

lemma row_echelon_form_dim0_col:
assumes "A  carrier_mat n 0"
shows "row_echelon_form A"
using assms
unfolding row_echelon_form_def pivot_fun_def Let_def by auto

lemma row_echelon_form_one_dim0[simp]: "row_echelon_form (1m 0)"
  unfolding row_echelon_form_def pivot_fun_def Let_def by auto

lemma Poly_list_of_vec_0[simp]: "Poly (list_of_vec (0v 0)) = [:0:]"
  by (simp add: poly_eq_iff nth_default_def)

lemma monic_normalize:
assumes "(p :: 'b :: {field,euclidean_ring_gcd} poly)  0" shows "monic (normalize p)"
by (simp add: assms normalize_poly_old_def)


lemma exists_factorization_prod_list:
fixes P::"'b::field poly list"
assumes "degree (prod_list P) > 0"
  and " u. u  set P  degree u > 0  monic u"
  and "square_free (prod_list P)"
shows "Q. prod_list Q = prod_list P  length P  length Q
            (u. u  set Q  irreducible u  monic u)"
using assms
proof (induct P)
  case Nil
  thus ?case by auto
next
  case (Cons x P)
  have sf_P: "square_free (prod_list P)"
    by (metis Cons.prems(3) dvd_triv_left prod_list.Cons mult.commute square_free_factor)
  have deg_x: "degree x > 0" using Cons.prems by auto
  have distinct_P: "distinct P"
    by (meson Cons.prems(2) Cons.prems(3) distinct.simps(2) square_free_prod_list_distinct)
  have "A. finite A  x = A  A  {q. irreducible q  monic q}"
    proof (rule monic_square_free_irreducible_factorization)
      show "monic x" by (simp add: Cons.prems(2))
      show "square_free x"
        by (metis Cons.prems(3) dvd_triv_left prod_list.Cons square_free_factor)
    qed
    from this obtain A where fin_A: "finite A"
    and xA: "x = A"
    and A: "A  {q. irreducibled q  monic q}"
    by auto
    obtain A' where s: "set A' = A" and length_A': "length A' = card A"
      using ‹finite A distinct_card finite_distinct_list by force
  have A_not_empty: "A  {}" using xA deg_x by auto
  have x_prod_list_A': "x = prod_list A'"
  proof -
    have "x = A" using xA by simp
    also have "... = prod id A" by simp
    also have "... = prod id (set A')" unfolding s by simp
    also have "... = prod_list (map id A')"
      by (rule prod.distinct_set_conv_list, simp add: card_distinct length_A' s)
    also have "... =  prod_list A'" by auto
    finally show ?thesis .
  qed
  show ?case
  proof (cases "P = []")
    case True
    show ?thesis
    proof (rule exI[of _ "A'"], auto simp add: True)
      show "prod_list A' = x" using x_prod_list_A' by simp
      show "Suc 0  length A'" using A_not_empty using s length_A'
        by (simp add: Suc_leI card_gt_0_iff fin_A)
      show "u. u  set A'  irreducible u" using s A by auto
      show "u. u  set A'  monic u" using s A by auto
    qed
 next
  case False
  have hyp: "Q. prod_list Q = prod_list P
     length P  length Q  (u. u  set Q  irreducible u  monic u)"
  proof (rule Cons.hyps[OF _ _ sf_P])
    have set_P: "set P  {}" using False by auto
    have "prod_list P = prod_list (map id P)" by simp
    also have "... = prod id (set P)"
      using prod.distinct_set_conv_list[OF distinct_P, of id] by simp
    also have "... = (set P)" by simp
    finally have "prod_list P = (set P)" .
    hence "degree (prod_list P) = degree ((set P))" by simp
    also have "... = degree (prod id (set P))" by simp
    also have "... = (i(set P). degree (id i))"
    proof (rule degree_prod_eq_sum_degree)
      show "iset P. id i  0" using Cons.prems(2) by force
    qed
    also have "... > 0"
      by (metis Cons.prems(2) List.finite_set set_P gr0I id_apply insert_iff list.set(2) sum_pos)
    finally show "degree (prod_list P) > 0" by simp
    show "u. u  set P  degree u > 0  monic u" using Cons.prems by auto
  qed
  from this obtain Q where QP: "prod_list Q = prod_list P" and length_PQ: "length P  length Q"
  and monic_irr_Q: "(u. u  set Q  irreducible u  monic u)" by blast
  show ?thesis
  proof (rule exI[of _ "A' @ Q"], auto simp add: monic_irr_Q)
    show "prod_list A' * prod_list Q = x * prod_list P" unfolding QP x_prod_list_A' by auto
    have "length A'  0" using A_not_empty using s length_A' by auto
    thus "Suc (length P)  length A' + length Q" using QP length_PQ by linarith
    show "u. u  set A'  irreducible u" using s A by auto
    show "u. u  set A'  monic u" using s A by auto
  qed
qed
qed

lemma normalize_eq_imp_smult:
  fixes p :: "'b :: {euclidean_ring_gcd} poly"
  assumes n: "normalize p = normalize q"
  shows " c. c  0  q = smult c p"
proof(cases "p = 0")
  case True with n show ?thesis by (auto intro:exI[of _ 1])
next
  case p0: False
  have degree_eq: "degree p = degree q" using n degree_normalize by metis
  hence q0:  "q  0" using p0 n by auto
  have p_dvd_q: "p dvd q" using n by (simp add: associatedD1)
  from p_dvd_q obtain k where q: "q = k * p" unfolding dvd_def by (auto simp: ac_simps)
  with q0 have "k  0" by auto
  then have "degree k = 0"
    using degree_eq degree_mult_eq p0 q by fastforce
  then obtain c where k: "k = [: c :]" by (metis degree_0_id)
  with k  0 have "c  0" by auto
  have "q = smult c p" unfolding q k by simp
  with c  0 show ?thesis by auto
qed

lemma prod_list_normalize: 
  fixes P :: "'b :: {idom_divide,normalization_semidom_multiplicative} poly list"
  shows "normalize (prod_list P) = prod_list (map normalize P)"
proof (induct P)
  case Nil
  show ?case by auto
next
  case (Cons p P)
  have "normalize (prod_list (p # P)) = normalize p * normalize (prod_list P)"
    using normalize_mult by auto
  also have "... = normalize p * prod_list (map normalize P)" using Cons.hyps by auto
  also have "... = prod_list (normalize p # (map normalize P))" by auto
  also have "... = prod_list (map normalize (p # P))" by auto
  finally show ?case .
qed


lemma prod_list_dvd_prod_list_subset:
fixes A::"'b::comm_monoid_mult list"
assumes dA: "distinct A"
  and dB: "distinct B" (*Maybe this condition could be avoided*)
  and s: "set A  set B"
shows "prod_list A dvd prod_list B"
proof -
  have "prod_list A = prod_list (map id A)" by auto
  also have "... = prod id (set A)"
    by (rule prod.distinct_set_conv_list[symmetric, OF dA])
  also have "... dvd prod id (set B)"
    by (rule prod_dvd_prod_subset[OF _ s], auto)
  also have "... = prod_list (map id B)"
    by (rule prod.distinct_set_conv_list[OF dB])
  also have "... = prod_list B" by simp
  finally show ?thesis .
qed

end

lemma gcd_monic_constant:
  "gcd f g  {1, f}" if "monic f" and "degree g = 0"
    for f g :: "'a :: {field_gcd} poly"
proof (cases "g = 0")
  case True
  moreover from ‹monic f have "normalize f = f"
    by (rule normalize_monic)
  ultimately show ?thesis
    by simp
next
  case False
  with ‹degree g = 0 have "is_unit g"
    by simp
  then have "Rings.coprime f g"
    by (rule is_unit_right_imp_coprime)
  then show ?thesis
    by simp
qed

lemma distinct_find_base_vectors:
fixes A::"'a::field mat"
assumes ref: "row_echelon_form A"
  and A: "A  carrier_mat nr nc"
shows "distinct (find_base_vectors A)"
proof -
  note non_pivot_base = non_pivot_base[OF ref A]
  let ?pp = "set (pivot_positions A)"
  from A have dim: "dim_row A = nr" "dim_col A = nc" by auto
  {
    fix j j'
    assume j: "j < nc" "j  snd ` ?pp" and j': "j' < nc" "j'  snd ` ?pp" and neq: "j'  j"
    from non_pivot_base(2)[OF j] non_pivot_base(4)[OF j' j neq]
    have "non_pivot_base A (pivot_positions A) j  non_pivot_base A (pivot_positions A) j'" by auto
  }
  hence inj: "inj_on (non_pivot_base A (pivot_positions A))
     (set [j[0..<nc] . j  snd ` ?pp])" unfolding inj_on_def by auto
  thus ?thesis unfolding  find_base_vectors_def Let_def unfolding distinct_map dim by auto
qed

lemma length_find_base_vectors:
fixes A::"'a::field mat"
assumes ref: "row_echelon_form A"
  and A: "A  carrier_mat nr nc"
shows "length (find_base_vectors A) = card (set (find_base_vectors A))"
using  distinct_card[OF distinct_find_base_vectors[OF ref A]] by auto


subsection ‹Previous Results›

definition power_poly_f_mod :: "'a::field poly  'a poly  nat  'a poly" where
  "power_poly_f_mod modulus = (λa n. a ^ n mod modulus)"

lemma power_poly_f_mod_binary: "power_poly_f_mod m a n = (if n = 0 then 1 mod m
    else let (d, r) = Divides.divmod_nat n 2;
       rec = power_poly_f_mod m ((a * a) mod m) d in
    if r = 0 then rec else (rec * a) mod m)"
  for m a :: "'a :: {field_gcd} poly"
proof -
  note d = power_poly_f_mod_def
  show ?thesis
  proof (cases "n = 0")
    case True
    thus ?thesis unfolding d by simp
  next
    case False
    obtain q r where div: "Divides.divmod_nat n 2 = (q,r)" by force
    hence n: "n = 2 * q + r" and r: "r = 0  r = 1" unfolding divmod_nat_def by auto
    have id: "a ^ (2 * q) = (a * a) ^ q"
      by (simp add: power_mult_distrib semiring_normalization_rules)
    show ?thesis
    proof (cases "r = 0")
      case True
      show ?thesis
        using power_mod [of "a * a" m q]
        by (auto simp add: divmod_nat_def Let_def True n d div id)
    next
      case False
      with r have r: "r = 1" by simp
      show ?thesis
        by (auto simp add: d r div Let_def mod_simps)
          (simp add: n r mod_simps ac_simps power_mult_distrib power_mult power2_eq_square)
    qed
  qed
qed


fun power_polys where
  "power_polys mul_p u curr_p (Suc i) = curr_p #
      power_polys mul_p u ((curr_p * mul_p) mod u) i"
| "power_polys mul_p u curr_p 0 = []"

context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin

lemma fermat_theorem_mod_ring [simp]:
  fixes a::"'a mod_ring"
  shows "a ^ CARD('a) = a"
proof (cases "a = 0")
  case True
  then show ?thesis by auto
next
  case False
  then show ?thesis
  proof transfer
    fix a
    assume "a  {0..<int CARD('a)}" and "a  0"
    then have a: "1  a" "a < int CARD('a)"
      by simp_all
    then have [simp]: "a mod int CARD('a) = a"
      by simp
    from a have "¬ int CARD('a) dvd a"
      by (auto simp add: zdvd_not_zless)
    then have "¬ CARD('a) dvd nat ¦a¦"
      by simp
    with a have "¬ CARD('a) dvd nat a"
      by simp
    with prime_card have "[nat a ^ (CARD('a) - 1) = 1] (mod CARD('a))"
      by (rule fermat_theorem)
    with a have "int (nat a ^ (CARD('a) - 1) mod CARD('a)) = 1"
      by (simp add: cong_def)
    with a have "a ^ (CARD('a) - 1) mod CARD('a) = 1"
      by (simp add: of_nat_mod)
    then have "a * (a ^ (CARD('a) - 1) mod int CARD('a)) = a"
      by simp
    then have "(a * (a ^ (CARD('a) - 1) mod int CARD('a))) mod int CARD('a) = a mod int CARD('a)"
      by (simp only:)
    then show "a ^ CARD('a) mod int CARD('a) = a"
      by (simp add: mod_simps semiring_normalization_rules(27))
  qed
qed


lemma mod_eq_dvd_iff_poly: "((x::'a mod_ring poly) mod n = y mod n) = (n dvd x - y)"
proof
  assume H: "x mod n = y mod n"
  hence "x mod n - y mod n = 0" by simp
  hence "(x mod n - y mod n) mod n = 0" by simp
  hence "(x - y) mod n = 0" by (simp add: mod_diff_eq)
  thus "n dvd x - y" by (simp add: dvd_eq_mod_eq_0)
next
  assume H: "n dvd x - y"
  then obtain k where k: "x-y = n*k" unfolding dvd_def by blast
  hence "x = n*k + y" using diff_eq_eq by blast
  hence "x mod n = (n*k + y) mod n" by simp
  thus "x mod n = y mod n" by (simp add: mod_add_left_eq)
qed

lemma cong_gcd_eq_poly:
  "gcd a m = gcd b m" if "[(a::'a mod_ring poly) = b] (mod m)"
  using that by (simp add: cong_def) (metis gcd_mod_left mod_by_0)

lemma coprime_h_c_poly:
fixes h::"'a mod_ring poly"
assumes "c1  c2"
shows "coprime (h - [:c1:]) (h - [:c2:])"
proof (intro coprimeI)
  fix d assume "d dvd h - [:c1:]"
  and "d dvd h - [:c2:]"
  hence "h mod d = [:c1:] mod d" and "h mod d = [:c2:] mod d"
    using mod_eq_dvd_iff_poly by simp+
  hence "[:c1:] mod d = [:c2:] mod d" by simp
  hence "d dvd [:c2 - c1:]"
    by (metis (no_types) mod_eq_dvd_iff_poly diff_pCons right_minus_eq)
  thus "is_unit d"
    by (metis (no_types) assms dvd_trans is_unit_monom_0 monom_0 right_minus_eq)
qed


lemma coprime_h_c_poly2:
fixes h::"'a mod_ring poly"
assumes "coprime (h - [:c1:]) (h - [:c2:])"
and "¬ is_unit (h - [:c1:])"
shows "c1  c2"
using assms coprime_id_is_unit by blast


lemma degree_minus_eq_right:
fixes p::"'b::ab_group_add poly"
shows "degree q < degree p  degree (p - q) = degree p"
using degree_add_eq_left[of "-q" p] degree_minus by auto

lemma coprime_prod:
  fixes A::"'a mod_ring set" and g::"'a mod_ring  'a mod_ring poly"
  assumes "xA. coprime (g a) (g x)"
  shows "coprime (g a) (prod (λx. g x) A)"
proof -
  have f: "finite A" by simp
  show ?thesis
  using f using assms
  proof (induct A)
    case (insert x A)
    have "(cinsert x A. g c) = (g x) * (cA. g c)"
      by (simp add: insert.hyps(2))
    with insert.prems show ?case
      by (auto simp: insert.hyps(3) prod_coprime_right)
  qed auto
qed


lemma coprime_prod2:
  fixes A::"'b::semiring_gcd set"
  assumes "xA. coprime (a) (x)" and f: "finite A"
  shows "coprime (a) (prod (λx. x) A)"
  using f using assms
proof (induct A)
  case (insert x A)
  have "(cinsert x A. c) = (x) * (cA. c)"
    by (simp add: insert.hyps)
  with insert.prems show ?case
    by (simp add: insert.hyps prod_coprime_right)
qed auto



lemma divides_prod:
  fixes g::"'a mod_ring  'a mod_ring poly"
  assumes "c1 c2. c1  A  c2  A  c1  c2  coprime (g c1) (g c2)"
  assumes "c A. g c dvd f"
  shows "(cA. g c) dvd f"
proof -
  have finite_A: "finite A" using finite[of A] .
  thus ?thesis using assms
  proof (induct A)
    case (insert x A)
    have "(cinsert x A. g c) =  g x * (c A. g c)"
      by (simp add: insert.hyps(2))
    also have "... dvd f"
    proof (rule divides_mult)
      show "g x dvd f" using insert.prems by auto
      show "prod g A dvd f" using insert.hyps(3) insert.prems by auto
      from insert show "Rings.coprime (g x) (prod g A)"
        by (auto intro: prod_coprime_right)
    qed
    finally show ?case .
   qed auto
qed

(*
  Proof of equation 9 in the book by Knuth
  x^p - x = (x-0)(x-1)...(x-(p-1))  (mod p)
*)

lemma poly_monom_identity_mod_p:
  "monom (1::'a mod_ring) (CARD('a)) - monom 1 1 = prod (λx. [:0,1:] - [:x:]) (UNIV::'a mod_ring set)"
  (is "?lhs = ?rhs")
proof -
  let ?f="(λx::'a mod_ring. [:0,1:] - [:x:])"
  have "?rhs dvd ?lhs"
  proof (rule divides_prod)
    {
    fix a::"'a mod_ring"
    have "poly ?lhs a = 0"
      by (simp add: poly_monom)
    hence "([:0,1:] - [:a:]) dvd ?lhs"
      using poly_eq_0_iff_dvd by fastforce
    }
    thus "xUNIV::'a mod_ring set. [:0, 1:] - [:x:] dvd monom 1 CARD('a) - monom 1 1" by fast
    show "c1 c2. c1  UNIV  c2  UNIV  c1  (c2 :: 'a mod_ring)  coprime ([:0, 1:] - [:c1:]) ([:0, 1:] - [:c2:])"
      by (auto dest!: coprime_h_c_poly[of _ _ "[:0,1:]"])
  qed
  from this obtain g where g: "?lhs = ?rhs * g" using dvdE by blast
  have degree_lhs_card: "degree ?lhs = CARD('a)"
  proof -
    have "degree (monom (1::'a mod_ring) 1) = 1" by (simp add: degree_monom_eq)
    moreover have d_c: "degree (monom (1::'a mod_ring) CARD('a)) = CARD('a)"
      by (simp add: degree_monom_eq)
    ultimately have "degree (monom (1::'a mod_ring) 1) < degree (monom (1::'a mod_ring) CARD('a))"
      using prime_card unfolding prime_nat_iff by auto
    hence "degree ?lhs = degree (monom (1::'a mod_ring) CARD('a))"
      by (rule degree_minus_eq_right)
    thus ?thesis unfolding d_c .
  qed
  have degree_rhs_card: "degree ?rhs = CARD('a)"
  proof -
    have "degree (prod ?f UNIV) = sum (degree  ?f) UNIV
       coeff (prod ?f UNIV) (sum (degree  ?f) UNIV) = 1"
      by (rule degree_prod_sum_monic, auto)
    moreover have "sum (degree  ?f) UNIV = CARD('a)" by auto
    ultimately show ?thesis by presburger
  qed
  have monic_lhs: "monic ?lhs" using degree_lhs_card by auto
  have monic_rhs: "monic ?rhs" by (rule monic_prod, simp)
  have degree_eq: "degree ?rhs = degree ?lhs" unfolding degree_lhs_card degree_rhs_card ..
  have g_not_0: "g  0" using g monic_lhs by auto
  have degree_g0: "degree g = 0"
  proof -
    have "degree (?rhs * g) = degree ?rhs + degree g"
      by (rule degree_monic_mult[OF monic_rhs g_not_0])
    thus ?thesis using degree_eq g by simp
  qed
  have monic_g: "monic g" using monic_factor g monic_lhs monic_rhs by auto
  have "g = 1" using monic_degree_0[OF monic_g] degree_g0 by simp
  thus ?thesis using g by auto
qed


(*
  Proof of equation 10 in the book by Knuth
  v(x)^p - v(x) = (v(x)-0)(v(x)-1)...(v(x)-(p-1))  (mod p)
*)


lemma poly_identity_mod_p:
  "v^(CARD('a)) - v = prod (λx. v - [:x:]) (UNIV::'a mod_ring set)"
 proof -
  have id: "monom 1 1 p v = v" "[:0, 1:] p v = v" unfolding pcompose_def
    apply (auto)
    by (simp add: fold_coeffs_def)
  have id2: "monom 1 (CARD('a)) p v = v ^ (CARD('a))" by (metis id(1) pcompose_hom.hom_power x_pow_n)
  show ?thesis using arg_cong[OF poly_monom_identity_mod_p, of "λ f. f p v"]
    unfolding pcompose_hom.hom_minus pcompose_hom.hom_prod id pcompose_const id2 .
qed



lemma coprime_gcd:
  fixes h::"'a mod_ring poly"
  assumes "Rings.coprime (h-[:c1:]) (h-[:c2:])"
  shows "Rings.coprime (gcd f(h-[:c1:])) (gcd f (h-[:c2:]))"
  using assms coprime_divisors by blast


lemma divides_prod_gcd:
  fixes h::"'a mod_ring poly"
  assumes "c1 c2. c1  A  c2  A  c1  c2 coprime (h-[:c1:]) (h-[:c2:])"
  shows "(cA. gcd f (h - [:c:])) dvd f"
proof -
  have finite_A: "finite A" using finite[of A] .
  thus ?thesis using assms
  proof (induct A)
    case (insert x A)
    have "(cinsert x A. gcd f (h - [:c:])) =  (gcd f (h - [:x:])) * (c A. gcd f (h - [:c:]))"
      by (simp add: insert.hyps(2))
    also have "... dvd f"
    proof (rule divides_mult)
      show "gcd f (h - [:x:]) dvd f" by simp
      show "(cA. gcd f (h - [:c:])) dvd f" using insert.hyps(3) insert.prems by auto
      show "Rings.coprime (gcd f (h - [:x:])) (cA. gcd f (h - [:c:]))"
        by (rule prod_coprime_right)
          (metis Berlekamp_Type_Based.coprime_h_c_poly coprime_gcd coprime_iff_coprime insert.hyps(2))
    qed
    finally show ?case .
   qed auto
qed

lemma monic_prod_gcd:
assumes f: "finite A" and f0: "(f :: 'b :: {field_gcd} poly)  0"
shows "monic (cA. gcd f (h - [:c:]))"
using f
proof (induct A)
  case (insert x A)
  have rw: "(cinsert x A. gcd f (h - [:c:]))
    = (gcd f (h - [:x:])) * (c A. gcd f (h - [:c:]))"
   by (simp add: insert.hyps)
  show ?case
  proof (unfold rw, rule monic_mult)
    show "monic (gcd f (h - [:x:]))"
      using poly_gcd_monic[of f] f0
      using insert.prems insert_iff by blast
    show "monic (cA. gcd f (h - [:c:]))"
      using insert.hyps(3) insert.prems by blast
  qed
qed auto

lemma coprime_not_unit_not_dvd:
fixes a::"'b::semiring_gcd"
assumes "a dvd b"
and "coprime b c"
and "¬ is_unit a"
shows "¬ a dvd c"
using assms coprime_divisors coprime_id_is_unit by fastforce

lemma divides_prod2:
  fixes A::"'b::semiring_gcd set"
  assumes f: "finite A"
  and "aA. a dvd c"
  and "a1 a2. a1  A  a2  A  a1  a2  coprime a1 a2"
  shows "A dvd c"
using assms
proof (induct A)
  case (insert x A)
  have "(insert x A) = x * A" by (simp add: insert.hyps(1) insert.hyps(2))
  also have "... dvd c"
  proof (rule divides_mult)
    show "x dvd c" by (simp add: insert.prems)
    show "A dvd c" using insert by auto
    from insert show "Rings.coprime x (A)"
      by (auto intro: prod_coprime_right)
  qed
  finally show ?case .
qed auto


lemma coprime_polynomial_factorization:
  fixes a1 :: "'b :: {field_gcd} poly"
  assumes  irr: "as  {q. irreducible q  monic q}"
  and "finite as" and a1: "a1  as" and a2: "a2  as" and a1_not_a2: "a1  a2"
  shows "coprime a1 a2"
proof (rule ccontr)
  assume not_coprime: "¬ coprime a1 a2"
  let ?b= "gcd a1 a2"
  have b_dvd_a1: "?b dvd a1" and b_dvd_a2: "?b dvd a2" by simp+
  have irr_a1: "irreducible a1" using a1 irr by blast
  have irr_a2: "irreducible a2" using a2 irr by blast
  have a2_not0: "a2  0" using a2 irr by auto
  have degree_a1: "degree a1  0" using irr_a1 by auto
  have degree_a2: "degree a2  0" using irr_a2 by auto
  have not_a2_dvd_a1: "¬ a2 dvd a1"
  proof (rule ccontr, simp)
    assume a2_dvd_a1: "a2 dvd a1"
    from this obtain k where k: "a1 = a2 * k" unfolding dvd_def by auto
    have k_not0: "k  0" using degree_a1 k by auto
    show False
    proof (cases "degree a2 = degree a1")
      case False
      have "degree a2 < degree a1"
        using False a2_dvd_a1 degree_a1 divides_degree
        by fastforce
      hence "¬ irreducible a1"
        using degree_a2 a2_dvd_a1 degree_a2
        by (metis degree_a1 irreducibledD(2) irreducibled_multD irreducible_connect_field k neq0_conv)
      thus False using irr_a1 by contradiction
    next
      case True
      have "degree a1 = degree a2 + degree k"
        unfolding k using degree_mult_eq[OF a2_not0 k_not0] by simp
      hence "degree k = 0" using True by simp
      hence "k = 1" using monic_factor a1 a2 irr k monic_degree_0 by auto
      hence "a1 = a2" using k by simp
      thus False using a1_not_a2 by contradiction
    qed
  qed
  have b_not0: "?b  0" by (simp add: a2_not0)
  have degree_b: "degree ?b > 0"
    using not_coprime[simplified] b_not0 is_unit_gcd is_unit_iff_degree by blast
  have "degree ?b < degree a2"
    by (meson b_dvd_a1 b_dvd_a2 irreducibleD' dvd_trans gcd_dvd_1 irr_a2 not_a2_dvd_a1 not_coprime)
  hence "¬ irreducibled a2" using degree_a2 b_dvd_a2 degree_b
    by (metis degree_smult_eq irreducibled_dvd_smult less_not_refl3)
  thus False using irr_a2 by auto
qed

(*
  Proof of equation 14 in the book by Knuth
*)
theorem Berlekamp_gcd_step:
fixes f::"'a mod_ring poly" and h::"'a mod_ring poly"
assumes hq_mod_f: "[h^(CARD('a)) = h] (mod f)" and monic_f: "monic f" and sf_f: "square_free f"
shows "f = prod (λc. gcd f (h - [:c:])) (UNIV::'a mod_ring set)"  (is "?lhs = ?rhs")
proof (cases "f=0")
  case True
  thus ?thesis using coeff_0 monic_f zero_neq_one by auto
  next
  case False note f_not_0 = False
  show ?thesis
  proof (rule poly_dvd_antisym)
    show "?rhs dvd f"
      using coprime_h_c_poly by (intro divides_prod_gcd, auto)
    have "monic ?rhs" by (rule monic_prod_gcd[OF _ f_not_0], simp)
    thus "coeff f (degree f) = coeff ?rhs (degree ?rhs)"
      using monic_f by auto
    next
    show "f dvd ?rhs"
    proof -
      let ?p = "CARD('a)"
      obtain P  where finite_P: "finite P"
      and f_desc_square_free: "f = (aP. a)"
      and P: "P  {q. irreducible q  monic q}"
        using monic_square_free_irreducible_factorization[OF monic_f sf_f] by auto
      have f_dvd_hqh: "f dvd (h^?p - h)" using hq_mod_f unfolding cong_def
        using mod_eq_dvd_iff_poly by blast
      also have hq_h_rw: "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)"
        by (rule poly_identity_mod_p)
      finally have f_dvd_hc: "f dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" by simp
      have "f = P" using f_desc_square_free by simp
      also have "... dvd ?rhs"
      proof (rule divides_prod2[OF finite_P])
        show "a1 a2. a1  P  a2  P  a1  a2  coprime a1 a2"
          using coprime_polynomial_factorization[OF P finite_P] by simp
        show "aP. a dvd (cUNIV. gcd f (h - [:c:]))"
        proof
          fix fi assume fi_P: "fi  P"
          show "fi dvd ?rhs"
          proof (rule dvd_prod, auto)
            show "fi dvd f" using f_desc_square_free fi_P
             using dvd_prod_eqI finite_P by blast
            hence "fi dvd (h^?p - h)" using dvd_trans f_dvd_hqh by auto
            also have "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)"
              unfolding hq_h_rw by simp
            finally have fi_dvd_prod_hc: "fi dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" .
            have irr_fi: "irreducible (fi)" using fi_P P by blast
            have fi_not_unit: "¬ is_unit fi" using irr_fi by (simp add: irreducibledD(1) poly_dvd_1)
            have fi_dvd_hc: "cUNIV::'a mod_ring set. fi dvd (h-[:c:])"
              by (rule irreducible_dvd_prod[OF _ fi_dvd_prod_hc], simp add: irr_fi)
            thus "c. fi dvd h - [:c:]" by simp
          qed
        qed
      qed
      finally show "f dvd ?rhs" .
    qed
  qed
qed


(******* Implementation of Berlekamp's algorithm (type-based version) *******)
subsection ‹Definitions›

definition berlekamp_mat :: "'a mod_ring poly  'a mod_ring mat" where
  "berlekamp_mat u = (let n = degree u;
    mul_p = power_poly_f_mod u [:0,1:] (CARD('a));
    xks = power_polys mul_p u 1 n
   in
    mat_of_rows_list n (map (λ cs. let coeffs_cs = (coeffs cs);
                                        k = n - length (coeffs cs)
                                   in (coeffs cs) @ replicate k 0) xks))"


definition berlekamp_resulting_mat :: "('a mod_ring) poly  'a mod_ring mat" where
"berlekamp_resulting_mat u = (let Q = berlekamp_mat u;
    n = dim_row Q;
    QI = mat n n (λ (i,j). if i = j then Q $$ (i,j) - 1 else Q $$ (i,j))
    in (gauss_jordan_single (transpose_mat QI)))"

definition berlekamp_basis :: "'a mod_ring poly  'a mod_ring poly list" where
  "berlekamp_basis u = (map (Poly o list_of_vec) (find_base_vectors (berlekamp_resulting_mat u)))"

lemma berlekamp_basis_code[code]: "berlekamp_basis u =
  (map (poly_of_list o list_of_vec) (find_base_vectors (berlekamp_resulting_mat u)))"
  unfolding berlekamp_basis_def poly_of_list_def ..

primrec berlekamp_factorization_main :: "nat  'a mod_ring poly list  'a mod_ring poly list  nat  'a mod_ring poly list" where
  "berlekamp_factorization_main i divs (v # vs) n = (if v = 1 then berlekamp_factorization_main i divs vs n else
    if length divs = n then divs else
    let facts = [ w . u  divs, s  [0 ..< CARD('a)], w  [gcd u (v - [:of_int s:])], w  1];
      (lin,nonlin) = List.partition (λ q. degree q = i) facts
      in lin @ berlekamp_factorization_main i nonlin vs (n - length lin))"
  | "berlekamp_factorization_main i divs [] n = divs"
  
definition berlekamp_monic_factorization :: "nat  'a mod_ring poly  'a mod_ring poly list" where
  "berlekamp_monic_factorization d f = (let
     vs = berlekamp_basis f;
     n = length vs;
     fs = berlekamp_factorization_main d [f] vs n
    in fs)"

subsection ‹Properties›

lemma power_polys_works:
fixes u::"'b::unique_euclidean_semiring"
assumes i: "i < n" and c: "curr_p = curr_p mod u" (*Equivalent to degree curr_p < degree u*)
shows "power_polys mult_p u curr_p n ! i = curr_p * mult_p ^ i mod u"
using i c
proof (induct n arbitrary: curr_p i)
  case 0 thus ?case by simp
next
  case (Suc n)
  have p_rw: "power_polys mult_p u curr_p (Suc n) ! i
      = (curr_p # power_polys mult_p u (curr_p * mult_p mod u) n) ! i"
    by simp
  show ?case
  proof (cases "i=0")
    case True
    show ?thesis using Suc.prems unfolding p_rw True by auto
  next
    case False note i_not_0 = False
    show ?thesis
    proof (cases "i < n")
      case True note i_less_n = True
      have "power_polys mult_p u curr_p (Suc n) ! i = power_polys mult_p u (curr_p * mult_p mod u) n ! (i - 1)"
        unfolding p_rw using nth_Cons_pos False by auto
      also have "... = (curr_p * mult_p mod u) * mult_p ^ (i-1) mod u"
        by (rule Suc.hyps) (auto simp add: i_less_n less_imp_diff_less)
      also have "... = curr_p * mult_p ^ i mod u"
        using False by (cases i) (simp_all add: algebra_simps mod_simps)
      finally show ?thesis .
    next
      case False
      hence i_n: "i = n" using Suc.prems by auto
      have "power_polys mult_p u curr_p (Suc n) ! i = power_polys mult_p u (curr_p * mult_p mod u) n ! (n - 1)"
          unfolding p_rw using nth_Cons_pos i_n i_not_0 by auto
      also have "... = (curr_p * mult_p mod u) * mult_p ^ (n-1) mod u"
      proof (rule Suc.hyps)
        show "n - 1 < n" using i_n i_not_0 by linarith
        show "curr_p * mult_p mod u = curr_p * mult_p mod u mod u" by simp
      qed
      also have "... = curr_p * mult_p ^ i mod u"
        using i_n [symmetric] i_not_0 by (cases i) (simp_all add: algebra_simps mod_simps)
      finally show ?thesis .
    qed
  qed
qed


lemma length_power_polys[simp]: "length (power_polys mult_p u curr_p n) = n"
  by (induct n arbitrary: curr_p, auto)


(*
  Equation 12
*)

lemma Poly_berlekamp_mat:
assumes k: "k < degree u"
shows "Poly (list_of_vec (row (berlekamp_mat u) k)) = [:0,1:]^(CARD('a) * k) mod u"
proof -
  let ?map ="(map (λcs. coeffs cs @ replicate (degree u - length (coeffs cs)) 0)
              (power_polys (power_poly_f_mod u [:0, 1:] (nat (int CARD('a)))) u 1 (degree u)))"
  have "row (berlekamp_mat u) k = row (mat_of_rows_list (degree u) ?map) k"
    by (simp add: berlekamp_mat_def Let_def)
  also have "... = vec_of_list (?map ! k)"
  proof-
    {
      fix i assume i: "i < degree u"
      let ?c= "power_polys (power_poly_f_mod u [:0, 1:] CARD('a)) u 1 (degree u) ! i"
      let ?coeffs_c="(coeffs ?c)"
      have "?c = 1*([:0, 1:] ^ CARD('a) mod u)^i mod u"
      proof (unfold power_poly_f_mod_def, rule power_polys_works[OF i])
        show "1 = 1 mod u" using k mod_poly_less by force
      qed
      also have "... = [:0, 1:] ^ (CARD('a) * i) mod u" by (simp add: power_mod power_mult)
      finally have c_rw: "?c = [:0, 1:] ^ (CARD('a) * i) mod u" .
      have "length ?coeffs_c  degree u"
      proof -
        show ?thesis
        proof (cases "?c = 0")
          case True thus ?thesis by auto
          next
          case False
          have "length ?coeffs_c = degree (?c) + 1" by (rule length_coeffs[OF False])
          also have "... = degree ([:0, 1:] ^ (CARD('a) * i) mod u) + 1" using c_rw by simp
          also have "...  degree u"
            by (metis One_nat_def add.right_neutral add_Suc_right c_rw calculation coeffs_def degree_0
              degree_mod_less discrete gr_implies_not0 k list.size(3) one_neq_zero)
          finally show ?thesis .
        qed
      qed
      then have "length ?coeffs_c + (degree u - length ?coeffs_c) = degree u" by auto
    }
    with k show ?thesis by (intro row_mat_of_rows_list, auto)
  qed
  finally have row_rw: "row (berlekamp_mat u) k = vec_of_list (?map ! k)" .
  have "Poly (list_of_vec (row (berlekamp_mat u) k)) = Poly (list_of_vec (vec_of_list (?map ! k)))"
    unfolding row_rw ..
  also have "... = Poly (?map ! k)" by simp
  also have "... = [:0,1:]^(CARD('a) * k) mod u"
  proof -
    let ?cs = "(power_polys (power_poly_f_mod u [:0, 1:] (nat (int CARD('a)))) u 1 (degree u)) ! k"
    let ?c = "coeffs ?cs @ replicate (degree u - length (coeffs ?cs)) 0"
    have map_k_c: "?map ! k = ?c" by (rule nth_map, simp add: k)
    have "(Poly (?map ! k)) = Poly (coeffs ?cs)" unfolding map_k_c Poly_append_replicate_0 ..
    also have "... = ?cs" by simp
    also have "... = power_polys ([:0, 1:] ^ CARD('a) mod u) u 1 (degree u) ! k"
      by (simp add: power_poly_f_mod_def)
    also have "... = 1* ([:0,1:]^(CARD('a)) mod u) ^ k mod u"
    proof (rule power_polys_works[OF k])
      show "1 = 1 mod u" using k mod_poly_less by force
    qed
    also have "... = ([:0,1:]^(CARD('a)) mod u) ^ k mod u" by auto
    also have "... = [:0,1:]^(CARD('a) * k) mod u" by (simp add: power_mod power_mult)
    finally show ?thesis .
  qed
    finally show ?thesis .
qed

corollary Poly_berlekamp_cong_mat:
assumes k: "k < degree u"
shows "[Poly (list_of_vec (row (berlekamp_mat u) k)) = [:0,1:]^(CARD('a) * k)] (mod u)"
using Poly_berlekamp_mat[OF k] unfolding cong_def by auto

lemma mat_of_rows_list_dim[simp]:
  "mat_of_rows_list n vs  carrier_mat (length vs) n"
  "dim_row (mat_of_rows_list n vs) = length vs"
  "dim_col (mat_of_rows_list n vs) = n"
  unfolding mat_of_rows_list_def by auto

lemma berlekamp_mat_closed[simp]:
  "berlekamp_mat u  carrier_mat (degree u) (degree u)"
  "dim_row (berlekamp_mat u) = degree u"
  "dim_col (berlekamp_mat u) = degree u"
 unfolding carrier_mat_def berlekamp_mat_def Let_def by auto


lemma vec_of_list_coeffs_nth:
assumes i: "i  {..degree h}" and h_not0: "h  0"
shows "vec_of_list (coeffs h) $ i = coeff h i"
proof -
  have "vec_of_list (map (coeff h) [0..<degree h] @ [coeff h (degree h)]) $ i = coeff h i"
      using i
      by (transfer', auto simp add: mk_vec_def)
         (metis (no_types, lifting) Cons_eq_append_conv coeffs_def coeffs_nth degree_0
         diff_zero length_upt less_eq_nat.simps(1) list.simps(8) list.simps(9) map_append
         nth_Cons_0 upt_Suc upt_eq_Nil_conv)
  thus "vec_of_list (coeffs h) $ i = coeff h i"
    using i h_not0
    unfolding coeffs_def by simp
qed



lemma poly_mod_sum:
  fixes x y z :: "'b::field poly"
  assumes f: "finite A"
  shows "sum f A mod z = sum (λi. f i mod z) A"
using f
by (induct, auto simp add: poly_mod_add_left)


lemma prime_not_dvd_fact:
assumes kn: "k < n" and prime_n: "prime n"
shows "¬ n dvd fact k"
using kn
proof (induct k)
  case 0
  thus ?case using prime_n unfolding prime_nat_iff by auto
next
  case (Suc k)
  show ?case
  proof (rule ccontr, unfold not_not)
    assume "n dvd fact (Suc k)"
    also have "... = Suc k * {1..k}" unfolding fact_Suc unfolding fact_prod by simp
    finally have "n dvd Suc k * {1..k}" .
    hence "n dvd Suc k  n dvd {1..k}" using prime_dvd_mult_eq_nat[OF prime_n] by blast
    moreover have  "¬ n dvd Suc k" by (simp add: Suc.prems(1) nat_dvd_not_less)
    moreover hence "¬ n dvd {1..k}" using Suc.hyps Suc.prems
      using Suc_lessD fact_prod[of k] by (metis of_nat_id)
    ultimately show False by simp
  qed
qed


lemma dvd_choose_prime:
assumes kn: "k < n" and k: "k  0" and n: "n  0" and prime_n: "prime n"
shows "n dvd (n choose k)"
proof -
  have "n dvd (fact n)" by (simp add: fact_num_eq_if n)
  moreover have "¬ n dvd (fact k * fact (n-k))"
  proof (rule ccontr, simp)
    assume "n dvd fact k * fact (n - k)"
    hence "n dvd fact k  n dvd fact (n - k)" using prime_dvd_mult_eq_nat[OF prime_n] by simp
    moreover have "¬ n dvd (fact k)" by (rule prime_not_dvd_fact[OF kn prime_n])
    moreover have "¬ n dvd fact (n - k)" using  prime_not_dvd_fact[OF _ prime_n] kn k by simp
    ultimately show False by simp
  qed
  moreover have "(fact n::nat) = fact k * fact (n-k) * (n choose k)"
    using binomial_fact_lemma kn by auto
  ultimately show ?thesis using prime_n
    by (auto simp add: prime_dvd_mult_iff)
qed



lemma add_power_poly_mod_ring:
fixes x :: "'a mod_ring poly"
shows "(x + y) ^ CARD('a) = x ^ CARD('a) + y ^ CARD('a)"
proof -
  let ?A="{0..CARD('a)}"
  let ?f="λk. of_nat (CARD('a) choose k) * x ^ k * y ^ (CARD('a) - k)"
  have A_rw: "?A = insert CARD('a) (insert 0 (?A - {0} - {CARD('a)}))"
    by fastforce
  have sum0: "sum ?f (?A - {0} - {CARD('a)}) = 0"
  proof (rule sum.neutral, rule)
    fix xa assume xa: "xa  {0..CARD('a)} - {0} - {CARD('a)}"
    have card_dvd_choose: "CARD('a) dvd  (CARD('a) choose xa)"
    proof (rule dvd_choose_prime)
      show "xa < CARD('a)" using xa by simp
      show "xa  0" using xa by simp
      show "CARD('a)  0" by simp
      show "prime CARD('a)" by (rule prime_card)
    qed
    hence rw0: "of_int (CARD('a) choose xa) = (0 :: 'a mod_ring)"
      by transfer simp
    have "of_nat (CARD('a) choose xa) = [:of_int (CARD('a) choose xa) :: 'a mod_ring:]"
      by (simp add: of_nat_poly)
    also have "... = [:0:]" using rw0 by simp
    finally show "of_nat (CARD('a) choose xa) * x ^ xa * y ^ (CARD('a) - xa) = 0" by auto
  qed
  have "(x + y)^CARD('a)
    = (k = 0..CARD('a). of_nat (CARD('a) choose k) * x ^ k * y ^ (CARD('a) - k))"
    unfolding binomial_ring by (rule sum.cong, auto)
  also have "... = sum ?f (insert CARD('a) (insert 0 (?A - {0} - {CARD('a)})))"
    using A_rw by simp
  also have "... = ?f 0 + ?f CARD('a) + sum ?f (?A - {0} - {CARD('a)})" by auto
  also have "... = x^CARD('a) + y^CARD('a)" unfolding sum0 by auto
  finally show ?thesis .
qed


lemma power_poly_sum_mod_ring:
fixes f :: "'b  'a mod_ring poly"
assumes f: "finite A"
shows "(sum f A) ^ CARD('a) = sum (λi. (f i) ^ CARD('a)) A"
using f by (induct, auto simp add: add_power_poly_mod_ring)


lemma poly_power_card_as_sum_of_monoms:
  fixes h :: "'a mod_ring poly"
  shows "h ^ CARD('a) = (idegree h. monom (coeff h i) (CARD('a)*i))"
proof -
  have "h ^ CARD('a) = (idegree h. monom (coeff h i) i) ^ CARD('a)"
    by (simp add: poly_as_sum_of_monoms)
  also have "... = (idegree h. (monom (coeff h i) i) ^ CARD('a))"
    by (simp add: power_poly_sum_mod_ring)
  also have "... = (idegree h. monom (coeff h i) (CARD('a)*i))"
  proof (rule sum.cong, rule)
    fix x assume x: "x  {..degree h}"
    show "monom (coeff h x) x ^ CARD('a) = monom (coeff h x) (CARD('a) * x)"
      by (unfold poly_eq_iff, auto simp add: monom_power)
  qed
  finally show ?thesis .
qed


lemma degree_Poly_berlekamp_le:
assumes i: "i < degree u"
shows "degree (Poly (list_of_vec (row (berlekamp_mat u) i))) < degree u"
by (metis Poly_berlekamp_mat degree_0 degree_mod_less gr_implies_not0 i linorder_neqE_nat)


(*
  Equation 12: alternative statement.
*)

lemma monom_card_pow_mod_sum_berlekamp:
assumes i: "i < degree u"
shows "monom 1 (CARD('a) * i) mod u = (j<degree u. monom ((berlekamp_mat u) $$ (i,j)) j)"
proof -
  let ?p = "Poly (list_of_vec (row (berlekamp_mat u) i))"
  have degree_not_0: "degree u  0" using i by simp
  hence set_rw: "{..degree u - 1} = {..<degree u}" by auto
  have degree_le: "degree ?p < degree u"
    by (rule degree_Poly_berlekamp_le[OF i])
  hence degree_le2: "degree ?p  degree u - 1" by auto
  have "monom 1 (CARD('a) * i) mod u = [:0, 1:] ^ (CARD('a) * i) mod u"
    using x_as_monom x_pow_n by metis
  also have "... = ?p"
    unfolding Poly_berlekamp_mat[OF i] by simp
  also have "... = (idegree u - 1. monom (coeff ?p i) i)"
        using degree_le2 poly_as_sum_of_monoms' by fastforce
  also have "... = (i<degree u. monom (coeff ?p i) i)" using set_rw by auto
  also have "... = (j<degree u. monom ((berlekamp_mat u) $$ (i,j)) j)"
  proof (rule sum.cong, rule)
    fix x assume x: "x  {..<degree u}"
    have "coeff ?p x = berlekamp_mat u $$ (i, x)"
    proof (rule coeff_Poly_list_of_vec_nth)
      show "x < dim_col (berlekamp_mat u)" using x by auto
    qed
    thus "monom (coeff ?p x) x = monom (berlekamp_mat u $$ (i, x)) x"
      by (simp add: poly_eq_iff)
  qed
  finally show ?thesis .
qed



lemma col_scalar_prod_as_sum:
assumes "dim_vec v = dim_row A"
shows "col A j  v = (i = 0..<dim_vec v. A $$ (i,j) * v $ i)"
  using assms
  unfolding col_def scalar_prod_def
  by transfer' (rule sum.cong, transfer', auto simp add: mk_vec_def mk_mat_def )

lemma row_transpose_scalar_prod_as_sum:
assumes j: "j < dim_col A" and dim_v: "dim_vec v = dim_row A"
shows "row (transpose_mat A) j  v = (i = 0..<dim_vec v. A $$ (i,j) * v $ i)"
proof -
  have "row (transpose_mat A) j  v = col A j  v" using j row_transpose by auto
  also have "... = (i = 0..<dim_vec v. A $$ (i,j) * v $ i)"
    by (rule col_scalar_prod_as_sum[OF dim_v])
  finally show ?thesis .
qed


lemma poly_as_sum_eq_monoms:
assumes ss_eq: "(i<n. monom (f i) i) = (i<n. monom (g i) i)"
and a_less_n: "a<n"
shows "f a = g a"
proof -
  let ?f="λi. if i = a then f i else 0"
  let ?g="λi. if i = a then g i else 0"
  have sum_f_0: "sum ?f ({..<n} - {a}) = 0" by (rule sum.neutral, auto)
  have "coeff (i<n. monom (f i) i) a = coeff (i<n. monom (g i) i) a"
    using ss_eq unfolding poly_eq_iff by simp
  hence "(i<n. coeff (monom (f i) i) a) = (i<n. coeff (monom (g i) i) a)"
    by (simp add: coeff_sum)
  hence 1: "(i<n. if i = a then f i else 0) = (i<n. if i = a then g i else 0)"
    unfolding coeff_monom by auto
  have set_rw: "{..<n} = (insert a ({..<n} - {a}))" using a_less_n by auto
  have "(i<n. if i = a then f i else 0) = sum ?f (insert a ({..<n} - {a}))"
    using set_rw by auto
  also have "... = ?f a + sum ?f ({..<n} - {a})"
    by (simp add: sum.insert_remove)
  also have "... = ?f a" using sum_f_0 by simp
  finally have 2: "(i<n. if i = a then f i else 0) = ?f a" .
  have "sum ?g {..<n} = sum ?g (insert a ({..<n} - {a}))"
    using set_rw by auto
  also have "... = ?g a + sum ?g ({..<n} - {a})"
    by (simp add: sum.insert_remove)
  also have "... = ?g a" using sum_f_0 by simp
  finally have 3: "(i<n. if i = a then g i else 0) = ?g a" .
  show ?thesis using 1 2 3 by auto
qed



lemma dim_vec_of_list_h:
assumes "degree h < degree u"
shows "dim_vec (vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0)) = degree u"
proof -
  have "length (coeffs h)  degree u"
    by (metis Suc_leI assms coeffs_0_eq_Nil degree_0 length_coeffs_degree
        list.size(3) not_le_imp_less order.asym)
  thus ?thesis by simp
qed




lemma vec_of_list_coeffs_nth':
assumes i: "i  {..degree h}" and h_not0: "h  0"
assumes "degree h < degree u"
shows "vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0) $ i = coeff h i"
using assms
by (transfer', auto simp add: mk_vec_def coeffs_nth length_coeffs_degree nth_append)


lemma vec_of_list_coeffs_replicate_nth_0:
assumes i: "i  {..<degree u}"
shows "vec_of_list (coeffs 0 @ replicate (degree u - length (coeffs 0)) 0) $ i = coeff 0 i"
using assms
by (transfer', auto simp add: mk_vec_def)


lemma vec_of_list_coeffs_replicate_nth:
assumes i: "i  {..<degree u}"
assumes "degree h < degree u"
shows "vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0) $ i = coeff h i"
proof (cases "h = 0")
  case True
  thus ?thesis using vec_of_list_coeffs_replicate_nth_0 i by auto
next
  case False note h_not0 = False
  show ?thesis
  proof (cases "i {..degree h}")
    case True thus ?thesis using assms vec_of_list_coeffs_nth' h_not0 by simp
  next
    case False
    have c0: "coeff h i = 0" using False le_degree by auto
    thus ?thesis
      using assms False h_not0
      by (transfer', auto simp add: mk_vec_def length_coeffs_degree nth_append c0)
  qed
qed


(*
  Equation 13
*)

lemma equation_13:
  fixes u h
  defines H: "H  vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0)"
  assumes deg_le: "degree h < degree u" (*Mandatory from equation 8*)
  shows "[h^CARD('a) = h] (mod u)  (transpose_mat (berlekamp_mat u)) *v H = H"
  (is "?lhs = ?rhs")
proof -
  have f: "finite {..degree u}" by auto
  have [simp]: "dim_vec H = degree u" unfolding H using dim_vec_of_list_h deg_le by simp
  let ?B = "(berlekamp_mat u)"
  let ?f = "λi. (transpose_mat ?B *v H) $ i"
  show ?thesis
  proof
  assume rhs: ?rhs
  have dimv_h_dimr_B: "dim_vec H = dim_row ?B"
    by (metis berlekamp_mat_closed(2) berlekamp_mat_closed(3)
        dim_mult_mat_vec index_transpose_mat(2) rhs)
  have degree_h_less_dim_H: "degree h < dim_vec H" by (auto simp add: deg_le)
  have set_rw: "{..degree u - 1} = {..<degree u}" using deg_le by auto
  have "degree h  degree u - 1" using deg_le by simp
  hence "h = (jdegree u - 1. monom (coeff h j) j)" using poly_as_sum_of_monoms' by fastforce
  also have "... = (j<degree u. monom (coeff h j) j)" using set_rw by simp
    also have "... = (j<degree u. monom (?f j) j)"
    proof (rule sum.cong, rule+)
      fix j assume i: "j  {..<degree u}"
      have "(coeff h j) = ?f j"
        using rhs vec_of_list_coeffs_replicate_nth[OF i deg_le]
        unfolding H by presburger
      thus "monom (coeff h j) j = monom (?f j) j"
        by simp
    qed
    also have "... = (j<degree u. monom (row (transpose_mat ?B) j  H) j)"
      by (rule sum.cong, auto)
    also have "... = (j<degree u. monom (i = 0..<dim_vec H. ?B $$ (i,j) * H $ i) j)"
    proof (rule sum.cong, rule)
      fix x assume x: "x  {..<degree u}"
      show "monom (row (transpose_mat ?B) x  H) x =
      monom (i = 0..<dim_vec H. ?B $$ (i, x) * H $ i) x"
      proof (unfold monom_eq_iff, rule row_transpose_scalar_prod_as_sum[OF _ dimv_h_dimr_B])
        show "x < dim_col ?B" using x deg_le by auto
      qed
    qed
    also have "... = (j<degree u. i = 0..<dim_vec H. monom (?B $$ (i,j) * H $ i) j)"
      by (auto simp add: monom_sum)
    also have "... = (i = 0..<dim_vec H. j<degree u. monom (?B $$ (i,j) * H $ i) j)"
      by (rule sum.swap)
    also have "... = (i = 0..<dim_vec H. j<degree u.  monom (H $ i) 0 * monom (?B $$ (i,j)) j)"
    proof (rule sum.cong, rule, rule sum.cong, rule)
       fix x xa
       show "monom (?B $$ (x, xa) * H $ x) xa = monom (H $ x) 0 * monom (?B $$ (x, xa)) xa"
        by (simp add: mult_monom)
    qed
    also have "... = (i = 0..<dim_vec H. (monom (H $ i) 0) * (j<degree u. monom (?B $$ (i,j)) j))"
      by (rule sum.cong, auto simp: sum_distrib_left)
    also have "... = (i = 0..<dim_vec H. (monom (H $ i) 0) * (monom 1 (CARD('a) * i) mod u))"
    proof (rule sum.cong, rule)
      fix x assume x: "x  {0..<dim_vec H}"
      have "(j<degree u. monom (?B $$ (x, j)) j) = (monom 1 (CARD('a) * x) mod u)"
      proof (rule monom_card_pow_mod_sum_berlekamp[symmetric])
        show "x < degree u" using x dimv_h_dimr_B by auto
      qed
      thus "monom (H $ x) 0 * (j<degree u. monom (?B $$ (x, j)) j) =
         monom (H $ x) 0 * (monom 1 (CARD('a) * x) mod u)" by presburger
    qed
    also have "... =  (i = 0..<dim_vec H. monom (H $ i) (CARD('a) * i) mod u)"
    proof (rule sum.cong, rule)
      fix x
      have h_rw: "monom (H $ x) 0 mod u = monom (H $ x) 0"
        by (metis deg_le degree_pCons_eq_if gr_implies_not_zero
           linorder_neqE_nat mod_poly_less monom_0)
      have "monom (H $ x) (CARD('a) * x) = monom (H $ x) 0 * monom 1 (CARD('a) * x)"
        unfolding mult_monom by simp
      also have "... = smult (H $ x) (monom 1 (CARD('a) * x))"
        by (simp add: monom_0)
      also have "... mod u =  Polynomial.smult (H $ x) (monom 1 (CARD('a) * x) mod u)"
        using mod_smult_left by auto
      also have "... = monom (H $ x) 0 * (monom 1 (CARD('a) * x) mod u)"
        by (simp add: monom_0)
      finally show "monom (H $ x) 0 * (monom 1 (CARD('a) * x) mod u)
        = monom (H $ x) (CARD('a) * x) mod u" ..
    qed
    also have "... = (i = 0..<dim_vec H. monom (H $ i) (CARD('a) * i)) mod u"
      by (simp add: poly_mod_sum)
    also have "... = (i = 0..<dim_vec H. monom (coeff h i) (CARD('a) * i)) mod u"
    proof (rule arg_cong[of _ _ "λx. x  mod u"], rule sum.cong, rule)
       fix x assume x: "x  {0..<dim_vec H}"
       have "H $ x = (coeff h x)"
       proof (unfold H, rule vec_of_list_coeffs_replicate_nth[OF _ deg_le])
          show "x  {..<degree u}" using x by auto
       qed
       thus "monom (H $ x) (CARD('a) * x) = monom (coeff h x) (CARD('a) * x)"
        by simp
    qed
    also have "... = (idegree h. monom (coeff h i) (CARD('a) * i)) mod u"
    proof (rule arg_cong[of _ _ "λx. x mod u"])
      let ?f="λi. monom (coeff h i) (CARD('a) * i)"
      have ss0: "(i = degree h + 1 ..< dim_vec H. ?f i) = 0"
        by (rule sum.neutral, simp add: coeff_eq_0)
      have set_rw: "{0..< dim_vec H} = {0..degree h}  {degree h + 1 ..< dim_vec H}"
        using degree_h_less_dim_H by auto
      have "(i = 0..<dim_vec H. ?f i) = (i = 0..degree h. ?f i) + (i = degree h + 1 ..< dim_vec H. ?f i)"
        unfolding set_rw by (rule sum.union_disjoint, auto)
      also have "... = (i = 0..degree h. ?f i)" unfolding ss0 by auto
      finally show "(i = 0..<dim_vec H. ?f i) = (idegree h. ?f i)"
        by (simp add: atLeast0AtMost)
    qed
    also have "... = h^CARD('a) mod u"
      using poly_power_card_as_sum_of_monoms by auto
    finally show ?lhs
      unfolding cong_def
      using deg_le
      by (simp add: mod_poly_less)
next
  assume lhs: ?lhs
  have deg_le': "degree h  degree u - 1" using deg_le by auto
  have set_rw: "{..<degree u} = {..degree u -1}" using deg_le by auto
  hence "(i<degree u. monom (coeff h i) i) = (i  degree u - 1. monom (coeff h i) i)" by simp
  also have "... = (idegree h. monom (coeff h i) i)"
    unfolding poly_as_sum_of_monoms
    using poly_as_sum_of_monoms' deg_le' by auto
  also have "... = (idegree h. monom (coeff h i) i) mod u"
    by (simp add: deg_le mod_poly_less poly_as_sum_of_monoms)
  also have "... = (idegree h. monom (coeff h i) (CARD('a)*i)) mod u"
     using lhs
     unfolding cong_def poly_as_sum_of_monoms poly_power_card_as_sum_of_monoms
     by auto
  also have "... = (idegree h. monom (coeff h i) 0 * monom 1 (CARD('a)*i)) mod u"
    by (rule arg_cong[of _ _ "λx. x mod u"], rule sum.cong, simp_all add: mult_monom)
  also have "... = (idegree h. monom (coeff h i) 0 * monom 1 (CARD('a)*i) mod u)"
    by (simp add: poly_mod_sum)
  also have "... = (idegree h. monom (coeff h i) 0 * (monom 1 (CARD('a)*i) mod u))"
  proof (rule sum.cong, rule)
    fix x assume x: "x  {..degree h}"
    have h_rw: "monom (coeff h x) 0 mod u = monom (coeff h x) 0"
        by (metis deg_le degree_pCons_eq_if gr_implies_not_zero
           linorder_neqE_nat mod_poly_less monom_0)
      have "monom (coeff h x) 0 * monom 1 (CARD('a) * x) = smult (coeff h x) (monom 1 (CARD('a) * x))"
        by (simp add: monom_0)
      also have "... mod u =  Polynomial.smult (coeff h x) (monom 1 (CARD('a) * x) mod u)"
        using mod_smult_left by auto
      also have "... = monom (coeff h x) 0 * (monom 1 (CARD('a) * x) mod u)"
        by (simp add: monom_0)
    finally show "monom (coeff h x) 0 * monom 1 (CARD('a) * x) mod u
      = monom (coeff h x) 0 * (monom 1 (CARD('a) * x) mod u)" .
  qed
  also have "... = (idegree h. monom (coeff h i) 0 * (j<degree u. monom (?B $$ (i, j)) j))"
  proof (rule sum.cong, rule)
    fix x assume x: "x  {..degree h}"
    have "(monom 1 (CARD('a) * x) mod u) = (j<degree u. monom (?B $$ (x, j)) j)"
    proof (rule monom_card_pow_mod_sum_berlekamp)
      show " x < degree u" using x deg_le by auto
    qed
    thus "monom (coeff h x) 0 * (monom 1 (CARD('a) * x) mod u) =
         monom (coeff h x) 0 * (j<degree u. monom (?B $$ (x, j)) j)" by simp
  qed
  also have "... = (i<degree u. monom (coeff h i) 0 * (j<degree u. monom (?B $$ (i, j)) j))"
  proof -
    let ?f="λi. monom (coeff h i) 0 * (j<degree u. monom (?B $$ (i, j)) j)"
    have ss0: "(i=degree h+1 ..< degree u. ?f i) = 0"
      by (rule sum.neutral, simp add: coeff_eq_0)
    have set_rw: "{0..<degree u} = {0..degree h}  {degree h+1..<degree u}" using deg_le by auto
    have "(i=0..<degree u. ?f i) = (i=0..degree h. ?f i) + (i=degree h+1 ..< degree u. ?f i)"
    unfolding set_rw by (rule sum.union_disjoint, auto)
    also have "... = (i=0..degree h. ?f i)" using ss0 by simp
    finally show ?thesis
      by (simp add: atLeast0AtMost atLeast0LessThan)
  qed
  also have "... = (i<degree u. (j<degree u. monom (coeff h i) 0 * monom (?B $$ (i, j)) j))"
    by (simp add: sum_distrib_left)
  also have "... = (i<degree u. (j<degree u. monom (coeff h i * ?B $$ (i, j)) j))"
    by (simp add: mult_monom)
  also have "... = (j<degree u. (i<degree u. monom (coeff h i * ?B $$ (i, j)) j))"
    using sum.swap by auto
  also have "... = (j<degree u. monom (i<degree u.  (coeff h i * ?B $$ (i, j))) j)"
    by (simp add: monom_sum)
  finally have ss_rw: "(i<degree u. monom (coeff h i) i)
    = (j<degree u. monom (i<degree u. coeff h i * ?B $$ (i, j)) j)" .
  have coeff_eq_sum: "i. i < degree u  coeff h i = (j<degree u. coeff h j * ?B $$ (j, i))"
    using poly_as_sum_eq_monoms[OF ss_rw] by fast
  have coeff_eq_sum': "i. i < degree u  H $ i = (j<degree u. H $ j * ?B $$ (j, i))"
  proof (rule+)
    fix i assume i: "i < degree u"
    have "H $ i = coeff h i" by (simp add: H deg_le i vec_of_list_coeffs_replicate_nth)
    also have "... = (j<degree u. coeff h j * ?B $$ (j, i))" using coeff_eq_sum i by blast
    also have "... = (j<degree u. H $ j * ?B $$ (j, i))"
      by (rule sum.cong, auto simp add: H deg_le vec_of_list_coeffs_replicate_nth)
    finally show "H $ i = (j<degree u. H $ j * ?B $$ (j, i))" .
  qed
  show "(transpose_mat (?B)) *v H = H"
  proof (rule eq_vecI)
    fix i
    show "dim_vec (transpose_mat ?B *v H) = dim_vec (H)" by auto
    assume i: "i < dim_vec (H)"
    have "(transpose_mat ?B *v H) $ i = row (transpose_mat ?B) i  H" using i by simp
    also have "... = (j = 0..<dim_vec H. ?B $$ (j, i) * H $ j)"
    proof (rule row_transpose_scalar_prod_as_sum)
      show "i < dim_col ?B" using i by simp
      show "dim_vec H = dim_row ?B" by simp
    qed
    also have "... = (j<degree u. H $ j * ?B $$ (j, i))" by (rule sum.cong, auto)
    also have "... = H $ i" using coeff_eq_sum'[rule_format, symmetric, of i] i by simp
    finally show "(transpose_mat ?B *v H) $ i = H $ i" .
  qed
 qed
qed


end


context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin

lemma exists_s_factor_dvd_h_s:
fixes fi::"'a mod_ring poly"
assumes finite_P: "finite P"
      and f_desc_square_free: "f = (aP. a)"
      and P: "P  {q. irreducible q  monic q}"
      and fi_P: "fi  P"
      and h: "h  {v. [v^(CARD('a)) = v] (mod f)}"
      shows "s. fi dvd (h - [:s:])"
proof -
  let ?p = "CARD('a)"
       have f_dvd_hqh: "f dvd (h^?p - h)" using h unfolding cong_def
        using mod_eq_dvd_iff_poly by blast
      also have hq_h_rw: "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)"
        by (rule poly_identity_mod_p)
      finally have f_dvd_hc: "f dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" by simp
          have "fi dvd f" using f_desc_square_free fi_P
            using dvd_prod_eqI finite_P by blast
          hence "fi dvd (h^?p - h)" using dvd_trans f_dvd_hqh by auto
          also have "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" unfolding hq_h_rw by simp
          finally have fi_dvd_prod_hc: "fi dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" .
          have irr_fi: "irreducible fi" using fi_P P by blast
          have fi_not_unit: "¬ is_unit fi" using irr_fi by (simp add: irreducibledD(1) poly_dvd_1)
          show ?thesis using irreducible_dvd_prod[OF _ fi_dvd_prod_hc] irr_fi by auto
qed


corollary exists_unique_s_factor_dvd_h_s:
  fixes fi::"'a mod_ring poly"
  assumes finite_P: "finite P"
    and f_desc_square_free: "f = (aP. a)"
    and P: "P  {q. irreducible q  monic q}"
    and fi_P: "fi  P"
    and h: "h  {v. [v^(CARD('a)) = v] (mod f)}"
    shows "∃!s. fi dvd (h - [:s:])"
proof -
  obtain c where fi_dvd: "fi dvd (h - [:c:])" using assms exists_s_factor_dvd_h_s by blast
  have irr_fi: "irreducible fi" using fi_P P by blast
  have fi_not_unit: "¬ is_unit fi"
    by (simp add: irr_fi irreducibledD(1) poly_dvd_1)
  show ?thesis
  proof (rule ex1I[of _ c], auto simp add: fi_dvd)
    fix c2 assume fi_dvd_hc2: "fi dvd h - [:c2:]"
    have *: "fi dvd (h - [:c:]) * (h - [:c2:])" using fi_dvd by auto
    hence "fi dvd (h - [:c:])  fi dvd (h - [:c2:])"
      using irr_fi by auto
    thus "c2 = c"
      using coprime_h_c_poly coprime_not_unit_not_dvd fi_dvd fi_dvd_hc2 fi_not_unit by blast
  qed
qed


lemma exists_two_distint: "a b::'a mod_ring. a  b"
by (rule exI[of _ 0], rule exI[of _ 1], auto)


lemma coprime_cong_mult_factorization_poly:
  fixes f::"'b::{field} poly"
    and a b p :: "'c :: {field_gcd} poly"
  assumes finite_P: "finite P"
    and P: "P  {q. irreducible q}"
    and p: "pP. [a=b] (mod p)"
    and coprime_P: "p1 p2. p1  P  p2  P  p1  p2  coprime p1 p2"
  shows "[a = b] (mod (aP. a))"
using finite_P P p coprime_P
proof (induct P)
  case empty
  thus ?case by simp
next
  case (insert p P)
  have ab_mod_pP: "[a=b] (mod (p * P))"
  proof (rule coprime_cong_mult_poly)
    show "[a = b] (mod p)" using insert.prems by auto
    show "[a = b] (mod P)" using insert.prems insert.hyps by auto
    from insert show "Rings.coprime p (P)"
      by (auto intro: prod_coprime_right)
  qed
  thus ?case by (simp add: insert.hyps(1) insert.hyps(2))
qed

end


context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin


lemma W_eq_berlekamp_mat:
fixes u::"'a mod_ring poly"
shows "{v. [v^CARD('a) = v] (mod u)  degree v < degree u}
  = {h. let H = vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0) in
    (transpose_mat (berlekamp_mat u)) *v H = H  degree h < degree u}"
  using equation_13 by (auto simp add: Let_def)

lemma transpose_minus_1:
  assumes "dim_row Q = dim_col Q"
  shows "transpose_mat (Q - (1m (dim_row Q))) =  (transpose_mat Q - (1m (dim_row Q)))"
  using assms
  unfolding mat_eq_iff by auto

lemma system_iff:
fixes v::"'b::comm_ring_1 vec"
assumes sq_Q: "dim_row Q = dim_col Q" and v: "dim_row Q = dim_vec v"
shows "(transpose_mat Q *v v = v)  ((transpose_mat Q - 1m (dim_row Q)) *v v = 0v (dim_vec v))"
proof -
  have t1:"transpose_mat Q *v v - v = 0v (dim_vec v)  (transpose_mat Q - 1m (dim_row Q)) *v v = 0v (dim_vec v)"
    by (subst minus_mult_distrib_mat_vec, insert sq_Q[symmetric] v, auto)
  have t2:"(transpose_mat Q - 1m (dim_row Q)) *v v = 0v (dim_vec v)  transpose_mat Q *v v - v = 0v (dim_vec v)"
    by (subst (asm) minus_mult_distrib_mat_vec, insert sq_Q[symmetric] v, auto)
  have "transpose_mat Q *v v - v = v - v  transpose_mat Q *v v = v"
  proof -
   assume a1: "transpose_mat Q *v v - v = v - v"
   have f2: "transpose_mat Q *v v  carrier_vec (dim_vec v)"
     by (metis dim_mult_mat_vec index_transpose_mat(2) sq_Q v carrier_vec_dim_vec)
   then have f3: "0v (dim_vec v) + transpose_mat Q *v v = transpose_mat Q *v v"
     by (meson left_zero_vec)
   have f4: "0v (dim_vec v) = transpose_mat Q *v v - v"
     using a1 by auto
   have f5: "- v  carrier_vec (dim_vec v)"
     by simp
   then have f6: "- v + transpose_mat Q *v v = v - v"
     using f2 a1 using comm_add_vec minus_add_uminus_vec by fastforce
   have "v - v = - v + v" by auto
   then have "transpose_mat Q *v v = transpose_mat Q *v v - v + v"
     using f6 f4 f3 f2 by (metis (no_types, lifting) a1 assoc_add_vec comm_add_vec f5 carrier_vec_dim_vec)
   then show ?thesis
     using a1 by auto
  qed
  hence "(transpose_mat Q *v v = v) = ((transpose_mat Q *v v) - v = v - v)" by auto
  also have "... = ((transpose_mat Q *v v) - v = 0v (dim_vec v))" by auto
  also have "... = ((transpose_mat Q - 1m (dim_row Q)) *v v = 0v (dim_vec v))"
    using t1 t2 by auto
  finally show ?thesis.
qed


lemma system_if_mat_kernel:
assumes sq_Q: "dim_row Q = dim_col Q" and v: "dim_row Q = dim_vec v"
shows "(transpose_mat Q *v v = v)  v  mat_kernel (transpose_mat (Q - (1m (dim_row Q))))"
proof -
  have "(transpose_mat Q *v v = v) = ((transpose_mat Q - 1m (dim_row Q)) *v v = 0v (dim_vec v))"
    using assms system_iff by blast
  also have "... = (v  mat_kernel (transpose_mat (Q - (1m (dim_row Q)))))"
    unfolding mat_kernel_def unfolding transpose_minus_1[OF sq_Q] unfolding v by auto
  finally show ?thesis .
qed



lemma degree_u_mod_irreducibled_factor_0:
fixes v and u::"'a mod_ring poly"
defines W: "W  {v. [v ^ CARD('a) = v] (mod u)}"
assumes v: "v  W"
and finite_U: "finite U" and u_U: "u = U" and U_irr_monic: "U  {q. irreducible q  monic q}"
and fi_U: "fi  U"
shows "degree (v mod fi) = 0"
proof -
  have deg_fi: "degree fi > 0"
    using U_irr_monic
    using fi_U irreducibledD[of fi] by auto
  have "fi dvd u"
    using u_U U_irr_monic finite_U dvd_prod_eqI fi_U by blast
  moreover have "u dvd (v^CARD('a) - v)"
    using v unfolding W cong_def
    by (simp add: mod_eq_dvd_iff_poly)
  ultimately have "fi dvd (v^CARD('a) - v)"
    by (rule dvd_trans)
  then have fi_dvd_prod_vc: "fi dvd prod (λc. v - [:c:]) (UNIV::'a mod_ring set)"
    by (simp add: poly_identity_mod_p)
  have irr_fi: "irreducible fi" using fi_U U_irr_monic by blast
  have fi_not_unit: "¬ is_unit fi"
    using irr_fi
    by (auto simp: poly_dvd_1)
  have fi_dvd_vc: "c. fi dvd v - [:c:]"
    using irreducible_dvd_prod[OF _ fi_dvd_prod_vc] irr_fi by auto
  from this obtain a where "fi dvd v - [:a:]" by blast
  hence "v mod fi = [:a:] mod fi" using mod_eq_dvd_iff_poly by blast
  also have "... = [:a:]" by (simp add: deg_fi mod_poly_less)
  finally show ?thesis by simp
qed


(* Also polynomials over a field as a vector space in HOL-Algebra.*)

definition "poly_abelian_monoid
  = carrier = UNIV::'a mod_ring poly set, monoid.mult = ((*)), one = 1, zero = 0, add = (+), module.smult = smult"

interpretation vector_space_poly: vectorspace class_ring poly_abelian_monoid
  rewrites [simp]: "𝟬poly_abelian_monoid = 0"
       and [simp]: "𝟭poly_abelian_monoid = 1"
       and [simp]: "(⊕poly_abelian_monoid) = (+)"
       and [simp]: "(⊗poly_abelian_monoid) = (*)"
       and [simp]: "carrier poly_abelian_monoid = UNIV"
       and [simp]: "(⊙poly_abelian_monoid) = smult"
  apply unfold_locales
  apply (auto simp: poly_abelian_monoid_def class_field_def smult_add_left smult_add_right Units_def)
  by (metis add.commute add.right_inverse)

lemma subspace_Berlekamp:
assumes f: "degree f  0"
shows "subspace (class_ring :: 'a mod_ring ring) 
  {v. [v^(CARD('a)) = v] (mod f)  (degree v < degree f)} poly_abelian_monoid"
proof -
  { fix v :: "'a mod_ring poly" and w :: "'a mod_ring poly"
    assume a1: "v ^ card (UNIV::'a set) mod f = v mod f"
    assume "w ^ card (UNIV::'a set) mod f = w mod f"
    then have "(v ^ card (UNIV::'a set) + w ^ card (UNIV::'a set)) mod f = (v + w) mod f"
      using a1 by (meson mod_add_cong)
    then have "(v + w) ^ card (UNIV::'a set) mod f = (v + w) mod f"
      by (simp add: add_power_poly_mod_ring)
  } note r=this
  thus ?thesis using f
   by (unfold_locales, auto simp: zero_power mod_smult_left smult_power cong_def degree_add_less)
qed


lemma berlekamp_resulting_mat_closed[simp]:
  "berlekamp_resulting_mat u  carrier_mat (degree u) (degree u)"
  "dim_row (berlekamp_resulting_mat u) = degree u"
  "dim_col (berlekamp_resulting_mat u) = degree u"
proof -
  let ?A="(transpose_mat (mat (degree u) (degree u)
             (λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j))))"
  let ?G="(gauss_jordan_single ?A)"
  have "?G carrier_mat (degree u) (degree u)"
    by (rule gauss_jordan_single(2)[of ?A], auto)
  thus
    "berlekamp_resulting_mat u  carrier_mat (degree u) (degree u)"
    "dim_row (berlekamp_resulting_mat u) = degree u"
    "dim_col (berlekamp_resulting_mat u) = degree u"
    unfolding berlekamp_resulting_mat_def Let_def by auto
qed


(*find_base vectors returns a basis:*)
lemma berlekamp_resulting_mat_basis:
"kernel.basis (degree u) (berlekamp_resulting_mat u) (set (find_base_vectors (berlekamp_resulting_mat u)))"
proof (rule find_base_vectors(3))
  show "berlekamp_resulting_mat u  carrier_mat (degree u) (degree u)" by simp
  let ?A="(transpose_mat (mat (degree u) (degree u)
          (λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j))))"
  have "row_echelon_form (gauss_jordan_single ?A)"
    by (rule gauss_jordan_single(3)[of ?A], auto)
  thus "row_echelon_form (berlekamp_resulting_mat u)"
    unfolding berlekamp_resulting_mat_def Let_def by auto
qed


lemma set_berlekamp_basis_eq: "(set (berlekamp_basis u))
  = (Poly  list_of_vec)` (set (find_base_vectors (berlekamp_resulting_mat u)))"
  by (auto simp add: image_def o_def berlekamp_basis_def)


lemma berlekamp_resulting_mat_constant:
assumes deg_u: "degree u = 0"
shows "berlekamp_resulting_mat u = 1m 0"
  by (unfold mat_eq_iff, auto simp add: deg_u)

context
  fixes u::"'a::prime_card mod_ring poly"
begin

lemma set_berlekamp_basis_constant:
assumes deg_u: "degree u = 0"
shows "set (berlekamp_basis u) = {}"
proof -
  have one_carrier: "1m 0  carrier_mat 0 0" by auto
  have m: "mat_kernel (1m 0) = {(0v 0) :: 'a mod_ring vec}" unfolding mat_kernel_def by auto
  have r: "row_echelon_form (1m 0 :: 'a mod_ring mat)"
    unfolding row_echelon_form_def pivot_fun_def Let_def by auto
  have "set (find_base_vectors (1m 0))  {0v 0 :: 'a mod_ring vec}"
    using find_base_vectors(1)[OF r one_carrier] unfolding m .
  hence "set (find_base_vectors (1m 0) :: 'a mod_ring vec list) = {}"
    using find_base_vectors(2)[OF r one_carrier]
    using subset_singletonD by fastforce
  thus ?thesis
    unfolding set_berlekamp_basis_eq  unfolding berlekamp_resulting_mat_constant[OF deg_u] by auto
qed

(*Maybe [simp]*)
lemma row_echelon_form_berlekamp_resulting_mat: "row_echelon_form (berlekamp_resulting_mat u)"
  by (rule gauss_jordan_single(3), auto simp add: berlekamp_resulting_mat_def Let_def)

lemma mat_kernel_berlekamp_resulting_mat_degree_0:
assumes d: "degree u = 0"
shows "mat_kernel (berlekamp_resulting_mat u) = {0v 0}"
  by (auto simp add: mat_kernel_def mult_mat_vec_def d)


lemma in_mat_kernel_berlekamp_resulting_mat:
assumes x: "transpose_mat (berlekamp_mat u) *v x = x"
and x_dim: "x  carrier_vec (degree u)"
shows "x  mat_kernel (berlekamp_resulting_mat u)"
proof -
 let ?QI="(mat(dim_row (berlekamp_mat u)) (dim_row (berlekamp_mat u))
         (λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j)))"
  have *: "(transpose_mat (berlekamp_mat u) - 1m (degree u)) = transpose_mat  ?QI" by auto
  have "(transpose_mat (berlekamp_mat u) - 1m (dim_row (berlekamp_mat u))) *v x = 0v (dim_vec x)"
    using system_iff[of "berlekamp_mat u" x] x_dim x by auto
  hence "transpose_mat ?QI *v x = 0v (degree u)" using x_dim * by auto
  hence "berlekamp_resulting_mat u *v x = 0v (degree u)"
    unfolding berlekamp_resulting_mat_def Let_def
    using gauss_jordan_single(1)[of "transpose_mat ?QI" "degree u" "degree u" _ x] x_dim by auto
  thus ?thesis by (auto simp add: mat_kernel_def x_dim)
qed

private abbreviation "V  kernel.VK (degree u) (berlekamp_resulting_mat u)"
private abbreviation "W  vector_space_poly.vs 
  {v. [v^(CARD('a)) = v] (mod u)  (degree v < degree u)}"

interpretation V: vectorspace class_ring V
proof -
  interpret k: kernel "(degree u)" "(degree u)" "(berlekamp_resulting_mat u)"
    by (unfold_locales; auto)
  show "vectorspace class_ring V" by intro_locales
qed

lemma linear_Poly_list_of_vec:
shows "(Poly  list_of_vec)  module_hom class_ring V (vector_space_poly.vs {v. [v^(CARD('a)) = v] (mod u)})"
proof (auto simp add: LinearCombinations.module_hom_def Matrix.module_vec_def)
  fix m1 m2::" 'a mod_ring vec"
  assume m1: "m1  mat_kernel (berlekamp_resulting_mat u)"
  and m2: "m2  mat_kernel (berlekamp_resulting_mat u)"
  have m1_rw: "list_of_vec m1 = map (λn. m1 $ n) [0..<dim_vec m1]"
    by (transfer, auto simp add: mk_vec_def)
  have m2_rw: "list_of_vec m2 = map (λn. m2 $ n) [0..<dim_vec m2]"
    by (transfer, auto simp add: mk_vec_def)
  have "m1  carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m1], auto)
  moreover have "m2  carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m2], auto)
  ultimately have dim_eq: "dim_vec m1 = dim_vec m2" by auto
  show "Poly (list_of_vec (m1 + m2)) = Poly (list_of_vec m1) + Poly (list_of_vec m2)"
    unfolding poly_eq_iff m1_rw m2_rw plus_vec_def
    using dim_eq
    by (transfer', auto simp add: mk_vec_def nth_default_def)
next
  fix r m assume m: "m  mat_kernel (berlekamp_resulting_mat u)"
  show "Poly (list_of_vec (r v m)) = smult r (Poly (list_of_vec m))"
    unfolding poly_eq_iff list_of_vec_rw_map[of m] smult_vec_def
    by (transfer', auto simp add: mk_vec_def nth_default_def)
next
  fix x assume x: "x  mat_kernel (berlekamp_resulting_mat u)"
  show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
  proof (cases "degree u = 0")
    case True
    have "mat_kernel (berlekamp_resulting_mat u) = {0v 0}"
      by (rule mat_kernel_berlekamp_resulting_mat_degree_0[OF True])
    hence x_0: "x = 0v 0" using x by blast
    show ?thesis by (auto simp add: zero_power x_0 cong_def)
  next
    case False note deg_u = False
    show ?thesis
    proof -
      let ?QI="(mat (degree u) (degree u)
      (λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j)))"
      let ?H="vec_of_list (coeffs (Poly (list_of_vec x)) @ replicate (degree u - length (coeffs (Poly (list_of_vec x)))) 0)"
      have x_dim: "dim_vec x = degree u" using x unfolding mat_kernel_def by auto
      hence x_carrier[simp]: "x  carrier_vec (degree u)" by (metis carrier_vec_dim_vec)
      have x_kernel: "berlekamp_resulting_mat u *v x = 0v (degree u)"
        using x unfolding mat_kernel_def by auto
      have t_QI_x_0: "(transpose_mat ?QI) *v x = 0v (degree u)"
        using gauss_jordan_single(1)[of "(transpose_mat ?QI)" "degree u" "degree u" "gauss_jordan_single (transpose_mat ?QI)" x]
        using x_kernel unfolding berlekamp_resulting_mat_def Let_def by auto
      have l: "(list_of_vec x)  []"
        by (auto simp add: list_of_vec_rw_map vec_of_dim_0[symmetric] deg_u x_dim)
      have deg_le: "degree (Poly (list_of_vec x)) < degree u"
        using degree_Poly_list_of_vec
        using x_carrier deg_u by blast
      show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
      proof (unfold equation_13[OF deg_le])
        have QR_rw: "?QI = berlekamp_mat u - 1m (dim_row (berlekamp_mat u))" by auto
        have "dim_row (berlekamp_mat u) = dim_vec ?H"
          by (auto, metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
        moreover have "?H  mat_kernel (transpose_mat (berlekamp_mat u - 1m (dim_row (berlekamp_mat u))))"
        proof -
           have Hx: "?H = x"
           proof (unfold vec_eq_iff, auto)
             let ?H'="vec_of_list (strip_while ((=) 0) (list_of_vec x)
              @ replicate (degree u - length (strip_while ((=) 0) (list_of_vec x))) 0)"
             show "length (strip_while ((=) 0) (list_of_vec x))
              + (degree u - length (strip_while ((=) 0) (list_of_vec x))) = dim_vec x"
                by (metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
             fix i assume i: "i < dim_vec x"
             have "?H $ i =  coeff (Poly (list_of_vec x)) i"
             proof (rule vec_of_list_coeffs_replicate_nth[OF _ deg_le])
              show "i  {..<degree u}"  using x_dim i by (auto, linarith)
             qed
             also have "... = x $ i" by (rule coeff_Poly_list_of_vec_nth'[OF i])
             finally show "?H' $ i = x $ i" by auto
           qed
           have "?H  carrier_vec (degree u)" using deg_le dim_vec_of_list_h Hx by auto
           moreover have "transpose_mat (berlekamp_mat u - 1m (degree u)) *v ?H = 0v (degree u)"
            using t_QI_x_0 Hx QR_rw by auto
           ultimately show ?thesis
            by (auto simp add: mat_kernel_def)
        qed
        ultimately show "transpose_mat (berlekamp_mat u) *v ?H = ?H"
          using system_if_mat_kernel[of "berlekamp_mat u" ?H]
          by auto
        qed
     qed
   qed
qed


lemma linear_Poly_list_of_vec':
  assumes "degree u > 0"
  shows "(Poly  list_of_vec)  module_hom R V W"
proof (auto simp add: LinearCombinations.module_hom_def Matrix.module_vec_def)
  fix m1 m2::" 'a mod_ring vec"
  assume m1: "m1  mat_kernel (berlekamp_resulting_mat u)"
  and m2: "m2  mat_kernel (berlekamp_resulting_mat u)"
  have m1_rw: "list_of_vec m1 = map (λn. m1 $ n) [0..<dim_vec m1]"
    by (transfer, auto simp add: mk_vec_def)
  have m2_rw: "list_of_vec m2 = map (λn. m2 $ n) [0..<dim_vec m2]"
    by (transfer, auto simp add: mk_vec_def)
  have "m1  carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m1], auto)
  moreover have "m2  carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m2], auto)
  ultimately have dim_eq: "dim_vec m1 = dim_vec m2" by auto
  show "Poly (list_of_vec (m1 + m2)) = Poly (list_of_vec m1) + Poly (list_of_vec m2)"
    unfolding poly_eq_iff m1_rw m2_rw plus_vec_def
    using dim_eq
    by (transfer', auto simp add: mk_vec_def nth_default_def)
next
  fix r m assume m: "m  mat_kernel (berlekamp_resulting_mat u)"
  show "Poly (list_of_vec (r v m)) = smult r (Poly (list_of_vec m))"
    unfolding poly_eq_iff list_of_vec_rw_map[of m] smult_vec_def
    by (transfer', auto simp add: mk_vec_def nth_default_def)
next
  fix x assume x: "x  mat_kernel (berlekamp_resulting_mat u)"
  show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
  proof (cases "degree u = 0")
    case True
    have "mat_kernel (berlekamp_resulting_mat u) = {0v 0}"
      by (rule mat_kernel_berlekamp_resulting_mat_degree_0[OF True])
    hence x_0: "x = 0v 0" using x by blast
    show ?thesis by (auto simp add: zero_power x_0 cong_def)
  next
    case False note deg_u = False
    show ?thesis
    proof -
      let ?QI="(mat (degree u) (degree u)
      (λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j)))"
      let ?H="vec_of_list (coeffs (Poly (list_of_vec x)) @ replicate (degree u - length (coeffs (Poly (list_of_vec x)))) 0)"
      have x_dim: "dim_vec x = degree u" using x unfolding mat_kernel_def by auto
      hence x_carrier[simp]: "x  carrier_vec (degree u)" by (metis carrier_vec_dim_vec)
      have x_kernel: "berlekamp_resulting_mat u *v x = 0v (degree u)"
        using x unfolding mat_kernel_def by auto
      have t_QI_x_0: "(transpose_mat ?QI) *v x = 0v (degree u)"
        using gauss_jordan_single(1)[of "(transpose_mat ?QI)" "degree u" "degree u" "gauss_jordan_single (transpose_mat ?QI)" x]
        using x_kernel unfolding berlekamp_resulting_mat_def Let_def by auto
      have l: "(list_of_vec x)  []"
        by (auto simp add: list_of_vec_rw_map vec_of_dim_0[symmetric] deg_u x_dim)
      have deg_le: "degree (Poly (list_of_vec x)) < degree u"
        using degree_Poly_list_of_vec
        using x_carrier deg_u by blast
      show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
      proof (unfold equation_13[OF deg_le])
        have QR_rw: "?QI = berlekamp_mat u - 1m (dim_row (berlekamp_mat u))" by auto
        have "dim_row (berlekamp_mat u) = dim_vec ?H"
          by (auto, metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
        moreover have "?H  mat_kernel (transpose_mat (berlekamp_mat u - 1m (dim_row (berlekamp_mat u))))"
        proof -
           have Hx: "?H = x"
           proof (unfold vec_eq_iff, auto)
             let ?H'="vec_of_list (strip_while ((=) 0) (list_of_vec x)
              @ replicate (degree u - length (strip_while ((=) 0) (list_of_vec x))) 0)"
             show "length (strip_while ((=) 0) (list_of_vec x))
              + (degree u - length (strip_while ((=) 0) (list_of_vec x))) = dim_vec x"
                by (metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
             fix i assume i: "i < dim_vec x"
             have "?H $ i =  coeff (Poly (list_of_vec x)) i"
             proof (rule vec_of_list_coeffs_replicate_nth[OF _ deg_le])
              show "i  {..<degree u}"  using x_dim i by (auto, linarith)
             qed
             also have "... = x $ i" by (rule coeff_Poly_list_of_vec_nth'[OF i])
             finally show "?H' $ i = x $ i" by auto
           qed
           have "?H  carrier_vec (degree u)" using deg_le dim_vec_of_list_h Hx by auto
           moreover have "transpose_mat (berlekamp_mat u - 1m (degree u)) *v ?H = 0v (degree u)"
            using t_QI_x_0 Hx QR_rw by auto
           ultimately show ?thesis
            by (auto simp add: mat_kernel_def)
        qed
        ultimately show "transpose_mat (berlekamp_mat u) *v ?H = ?H"
          using system_if_mat_kernel[of "berlekamp_mat u" ?H]
          by auto
        qed
     qed
   qed
next
  fix x assume x: "x  mat_kernel (berlekamp_resulting_mat u)"
  show "degree (Poly (list_of_vec x)) < degree u"
    by (rule degree_Poly_list_of_vec, insert assms x, auto simp: mat_kernel_def)
qed


lemma berlekamp_basis_eq_8:
  assumes v: "v  set (berlekamp_basis u)"
  shows "[v ^ CARD('a) = v] (mod u)"
proof -
  {
      fix x assume x: "x  set (find_base_vectors (berlekamp_resulting_mat u))"
      have "set (find_base_vectors (berlekamp_resulting_mat u))  mat_kernel (berlekamp_resulting_mat u)"
      proof (rule find_base_vectors(1))
        show "row_echelon_form (berlekamp_resulting_mat u)"
          by (rule row_echelon_form_berlekamp_resulting_mat)
        show "berlekamp_resulting_mat u  carrier_mat (degree u) (degree u)" by simp
      qed
      hence "x  mat_kernel (berlekamp_resulting_mat u)" using x by auto
      hence "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
        using linear_Poly_list_of_vec
        unfolding LinearCombinations.module_hom_def Matrix.module_vec_def by auto
  }
  thus "[v ^ CARD('a) = v] (mod u)" using v unfolding set_berlekamp_basis_eq by auto
qed


lemma surj_Poly_list_of_vec:
  assumes deg_u: "degree u > 0"
  shows "(Poly  list_of_vec)` (carrier V) = carrier W"
proof (auto simp add: image_def)
  fix xa
  assume xa: "xa  mat_kernel (berlekamp_resulting_mat u)"
  thus "[Poly (list_of_vec xa) ^ CARD('a) = Poly (list_of_vec xa)] (mod u)"
    using linear_Poly_list_of_vec
    unfolding LinearCombinations.module_hom_def Matrix.module_vec_def by auto
  show "degree (Poly (list_of_vec xa)) < degree u"
  proof (rule degree_Poly_list_of_vec[OF _ deg_u])
    show "xa  carrier_vec (degree u)" using xa unfolding mat_kernel_def by simp
  qed
next
  fix x assume x: "[x ^ CARD('a) = x] (mod u)"
  and deg_x: "degree x < degree u"
  show "xa  mat_kernel (berlekamp_resulting_mat u). x = Poly (list_of_vec xa)"
  proof (rule bexI[of _ "vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)"])
    let ?X = "vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)"
    show "x = Poly (list_of_vec (vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)))"
      by auto
    have X: "?X  carrier_vec (degree u)" unfolding carrier_vec_def
      by (auto, metis Suc_leI coeffs_0_eq_Nil deg_x degree_0 le_add_diff_inverse
        length_coeffs_degree linordered_semidom_class.add_diff_inverse list.size(3) order.asym)
    have t: "transpose_mat (berlekamp_mat u) *v ?X = ?X"
      using equation_13[OF deg_x] x by auto
    show "vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)
       mat_kernel (berlekamp_resulting_mat u)" by (rule in_mat_kernel_berlekamp_resulting_mat[OF t X])
  qed
qed


lemma card_set_berlekamp_basis: "card (set (berlekamp_basis u)) = length (berlekamp_basis u)"
proof -
  have b: "berlekamp_resulting_mat u  carrier_mat (degree u) (degree u)" by auto
  have "(set (berlekamp_basis u)) = (Poly  list_of_vec) ` set (find_base_vectors (berlekamp_resulting_mat u))"
    unfolding set_berlekamp_basis_eq ..
  also have " card ... = card (set (find_base_vectors (berlekamp_resulting_mat u)))"
  proof (rule card_image, rule subset_inj_on[OF inj_Poly_list_of_vec])
    show "set (find_base_vectors (berlekamp_resulting_mat u))  carrier_vec (degree u)"
    using find_base_vectors(1)[OF row_echelon_form_berlekamp_resulting_mat b]
    unfolding carrier_vec_def mat_kernel_def
    by auto
  qed
  also have "... =  length (find_base_vectors (berlekamp_resulting_mat u))"
    by (rule length_find_base_vectors[symmetric, OF row_echelon_form_berlekamp_resulting_mat b])
  finally show ?thesis unfolding berlekamp_basis_def by auto
qed

context
  assumes deg_u0[simp]: "degree u > 0"
begin

interpretation Berlekamp_subspace: vectorspace class_ring W
  by (rule vector_space_poly.subspace_is_vs[OF subspace_Berlekamp], simp)

lemma linear_map_Poly_list_of_vec': "linear_map class_ring V W (Poly  list_of_vec)"
proof (auto simp add: linear_map_def)
  show "vectorspace class_ring V" by intro_locales
  show "vectorspace class_ring W" by (rule Berlekamp_subspace.vectorspace_axioms)
  show "mod_hom class_ring V W (Poly  list_of_vec)"
  proof (rule mod_hom.intro, unfold mod_hom_axioms_def)
    show "module class_ring V" by intro_locales
    show "module class_ring W" using Berlekamp_subspace.vectorspace_axioms by intro_locales
    show "Poly  list_of_vec  module_hom class_ring V W"
      by (rule linear_Poly_list_of_vec'[OF deg_u0])
  qed
qed

lemma berlekamp_basis_basis:
  "Berlekamp_subspace.basis (set (berlekamp_basis u))"
proof (unfold set_berlekamp_basis_eq, rule linear_map.linear_inj_image_is_basis)
  show "linear_map class_ring V W (Poly  list_of_vec)"
    by (rule linear_map_Poly_list_of_vec')
  show "inj_on (Poly  list_of_vec) (carrier V)"
  proof (rule subset_inj_on[OF inj_Poly_list_of_vec])
    show "carrier V  carrier_vec (degree u)"
      by (auto simp add: mat_kernel_def)
  qed
  show "(Poly  list_of_vec) ` carrier V = carrier W"
    using surj_Poly_list_of_vec[OF deg_u0] by auto
  show b: "V.basis (set (find_base_vectors (berlekamp_resulting_mat u)))"
    by (rule berlekamp_resulting_mat_basis)
  show "V.fin_dim"
  proof -
    have "finite (set (find_base_vectors (berlekamp_resulting_mat u)))" by auto
    moreover have "set (find_base_vectors (berlekamp_resulting_mat u))  carrier V"
    and "V.gen_set (set (find_base_vectors (berlekamp_resulting_mat u)))"
      using b unfolding V.basis_def by auto
    ultimately show ?thesis unfolding V.fin_dim_def by auto
  qed
qed


lemma finsum_sum:
fixes f::"'a mod_ring poly"
assumes f: "finite B"
and a_Pi: "a  B  carrier R"
and V: "B  carrier W"
shows "(WvB. a v W v) = sum (λv. smult (a v) v) B"
using f a_Pi V
proof (induct B)
  case empty
  thus ?case unfolding Berlekamp_subspace.module.M.finsum_empty by auto
  next
  case (insert x V)
  have hyp: "(Wv  V. a v W v) = sum (λv. smult (a v) v) V"
  proof (rule insert.hyps)
    show "a  V  carrier R"
      using insert.prems unfolding class_field_def  by auto
     show "V  carrier W" using insert.prems by simp
  qed
  have "(Wvinsert x V. a v W v) =  (a x W x) W (Wv  V. a v W v)"
  proof (rule abelian_monoid.finsum_insert)
    show "abelian_monoid W" by (unfold_locales)
    show "finite V" by fact
    show "x  V" by fact
    show "(λv. a v W v)  V  carrier W"
      proof (unfold Pi_def, rule, rule allI, rule impI)
        fix v assume v: "vV"
        show "a v W v  carrier W"
        proof (rule Berlekamp_subspace.smult_closed)
          show "a v  carrier class_ring" using insert.prems v unfolding Pi_def
            by (simp add: class_field_def)
          show "v  carrier W" using v insert.prems by auto
        qed
      qed
    show "a x W x  carrier W"
    proof (rule Berlekamp_subspace.smult_closed)
      show "a x  carrier class_ring" using insert.prems unfolding Pi_def
        by (simp add: class_field_def)
      show "x  carrier W" using insert.prems by auto
    qed
  qed
  also have "... = (a x W x) + (Wv  V. a v W v)" by auto
  also have "... = (a x W x) + sum (λv. smult (a v) v) V" unfolding hyp by simp
  also have "... = (smult (a x) x) + sum (λv. smult (a v) v) V" by simp
  also have "... = sum (λv. smult (a v) v) (insert x V)"
    by (simp add: insert.hyps(1) insert.hyps(2))
  finally show ?case .
qed


lemma exists_vector_in_Berlekamp_subspace_dvd:
fixes p_i::"'a mod_ring poly"
assumes finite_P: "finite P"
      and f_desc_square_free: "u = (aP. a)"
      and P: "P  {q. irreducible q  monic q}"
      and pi: "p_i  P" and pj: "p_j  P" and pi_pj: "p_i  p_j"
      and monic_f: "monic u" and sf_f: "square_free u"
      and not_irr_w: "¬ irreducible w"
      and w_dvd_f: "w dvd u" and monic_w: "monic w"
      and pi_dvd_w: "p_i dvd w" and pj_dvd_w: "p_j dvd w"
shows "v. v  {h. [h^(CARD('a)) = h] (mod u)  degree h < degree u}
   v mod p_i  v mod p_j
   degree (v mod p_i) = 0
   degree (v mod p_j) = 0
― ‹This implies that the algorithm decreases the degree of the reducible polynomials in each step:›
   (s. gcd w (v - [:s:])  w  gcd w (v - [:s:])  1)"
proof -
  have f_not_0: "u  0" using monic_f by auto
  have irr_pi: "irreducible p_i" using pi P by auto
  have irr_pj: "irreducible p_j" using pj P by auto
  obtain m and n::nat where P_m: "P = m ` {i. i < n}" and inj_on_m: "inj_on m {i. i < n}"
    using finite_imp_nat_seg_image_inj_on[OF finite_P] by blast
  hence "n = card P" by (simp add: card_image)
  have degree_prod: "degree (prod m {i. i < n}) = degree u"
    by (metis P_m f_desc_square_free inj_on_m prod.reindex_cong)
  have not_zero: "i{i. i < n}. m i  0"
    using P_m f_desc_square_free f_not_0 by auto
  obtain i where mi: "m i = p_i" and i: "i < n" using P_m pi by blast
  obtain j where mj: "m j = p_j" and j: "j < n" using P_m pj by blast
  have ij: "i  j"  using  mi mj pi_pj by auto
  obtain s_i and s_j::"'a mod_ring" where si_sj: "s_i  s_j" using exists_two_distint by blast
  let ?u="λx. if x = i then [:s_i:] else if x = j then [:s_j:] else [:0:]"
  have degree_si: "degree [:s_i:] = 0" by auto
  have degree_sj: "degree [:s_j:] = 0" by auto
  have "∃!v. degree v < (i{i. i < n}. degree (m i))  (a{i. i < n}. [v = ?u a] (mod m a))"
  proof (rule chinese_remainder_unique_poly)
    show "a{i. i < n}. b{i. i < n}. a  b  Rings.coprime (m a) (m b)"
    proof (rule+)
      fix a b assume "a  {i. i < n}" and "b  {i. i < n}" and "a  b"
      thus "Rings.coprime (m a) (m b)"
        using coprime_polynomial_factorization[OF P finite_P, simplified] P_m
        by (metis image_eqI inj_onD inj_on_m)
    qed
    show "i{i. i < n}. m i  0" by (rule not_zero)
    show "0 < degree (prod m {i. i < n})" unfolding degree_prod using deg_u0 by blast
  qed
  from this obtain v where v: "a{i. i < n}. [v = ?u a] (mod m a)"
  and degree_v: "degree v < (i{i. i < n}. degree (m i))" by blast
  show ?thesis
  proof (rule exI[of _ v], auto)
    show vp_v_mod: "[v ^ CARD('a) = v] (mod u)"
    proof (unfold f_desc_square_free, rule coprime_cong_mult_factorization_poly[OF finite_P])
      show "P  {q. irreducible q}" using P by blast
      show "pP. [v ^ CARD('a) = v] (mod p)"
      proof (rule ballI)
        fix p assume p: "p  P"
        hence irr_p: "irreducibled p" using P by auto
        obtain k where mk: "m k = p" and k: "k < n" using P_m p by blast
        have "[v = ?u k] (mod p)" using v mk k by auto
        moreover have "?u k mod p = ?u k"
          apply (rule mod_poly_less) using irreducibledD(1)[OF irr_p] by auto
        ultimately obtain s where v_mod_p: "v mod p = [:s:]" unfolding cong_def by force
        hence deg_v_p: "degree (v mod p) = 0" by auto
        have "v mod p = [:s:]" by (rule v_mod_p)
        also have "... = [:s:]^CARD('a)" unfolding poly_const_pow by auto
        also have "... = (v mod p) ^ CARD('a)" using v_mod_p by auto
        also have "... = (v mod p) ^ CARD('a) mod p" using calculation by auto
        also have "... = v^CARD('a) mod p" using power_mod by blast
        finally show "[v ^ CARD('a) = v] (mod p)" unfolding cong_def ..
      qed
      show "p1 p2. p1  P  p2  P  p1  p2  coprime p1 p2"
        using P coprime_polynomial_factorization finite_P by auto
    qed
    have "[v = ?u i] (mod m i)" using v i by auto
    hence v_pi_si_mod: "v mod p_i = [:s_i:] mod p_i" unfolding cong_def mi by auto
    also have "... = [:s_i:]" apply (rule mod_poly_less) using irr_pi by auto
    finally have v_pi_si: "v mod p_i = [:s_i:]" .

    have "[v = ?u j] (mod m j)" using v j by auto
    hence v_pj_sj_mod: "v mod p_j = [:s_j:] mod p_j" unfolding cong_def mj using ij by auto
    also have "... = [:s_j:]" apply (rule mod_poly_less) using irr_pj by auto
    finally have v_pj_sj: "v mod p_j = [:s_j:]" .
    show "v mod p_i = v mod p_j  False" using si_sj v_pi_si v_pj_sj by auto
    show "degree (v mod p_i) = 0" unfolding v_pi_si by simp
    show "degree (v mod p_j) = 0" unfolding v_pj_sj by simp
    show "s. gcd w (v - [:s:])  w  gcd w (v - [:s:])  1"
    proof (rule exI[of _ s_i], rule conjI)
      have pi_dvd_v_si: "p_i dvd v - [:s_i:]" using v_pi_si_mod mod_eq_dvd_iff_poly by blast
      have pj_dvd_v_sj: "p_j dvd v - [:s_j:]" using v_pj_sj_mod mod_eq_dvd_iff_poly by blast
      have w_eq: "w = prod (λc. gcd w (v - [:c:])) (UNIV::'a mod_ring set)"
      proof (rule Berlekamp_gcd_step)
        show "[v ^ CARD('a) = v] (mod w)" using vp_v_mod cong_dvd_modulus_poly w_dvd_f by blast
        show "square_free w" by (rule square_free_factor[OF w_dvd_f sf_f])
        show "monic w" by (rule monic_w)
      qed
      show "gcd w (v - [:s_i:])  w"
      proof (rule ccontr, simp)
        assume gcd_w: "gcd w (v - [:s_i:]) = w"
        show False apply (rule v mod p_i = v mod p_j  False›)
        by (metis irreducibleE ‹degree (v mod p_i) = 0 gcd_greatest_iff gcd_w irr_pj is_unit_field_poly mod_eq_dvd_iff_poly mod_poly_less neq0_conv pj_dvd_w v_pi_si)
      qed
      show "gcd w (v - [:s_i:])  1"
        by (metis irreducibleE gcd_greatest_iff irr_pi pi_dvd_v_si pi_dvd_w)
    qed
    show "degree v < degree u"
    proof -
      have "(i | i < n. degree (m i)) = degree (prod m {i. i < n})"
        by (rule degree_prod_eq_sum_degree[symmetric, OF not_zero])
      thus ?thesis using degree_v unfolding degree_prod by auto
    qed
  qed
qed



lemma exists_vector_in_Berlekamp_basis_dvd_aux:
assumes basis_V: "Berlekamp_subspace.basis B"
  and finite_V: "finite B" (*This should be removed, since the Berlekamp subspace is a finite set*)
assumes finite_P: "finite P"
      and f_desc_square_free: "u = (aP. a)"
      and P: "P  {q. irreducible q  monic q}"
      and pi: "p_i  P" and pj: "p_j  P" and pi_pj: "p_i  p_j"
      and monic_f: "monic u" and sf_f: "square_free u"
      and not_irr_w: "¬ irreducible w"
      and w_dvd_f: "w dvd u" and monic_w: "monic w"
      and pi_dvd_w: "p_i dvd w" and pj_dvd_w: "p_j dvd w"
    shows "v  B. v mod p_i  v mod p_j"
proof (rule ccontr, auto)
  have V_in_carrier: "B  carrier W"
    using basis_V unfolding Berlekamp_subspace.basis_def by auto
  assume all_eq: "vB. v mod p_i = v mod p_j"
  obtain x where x: "x  {h. [h ^ CARD('a) = h] (mod u)  degree h < degree u}"
      and x_pi_pj: "x mod p_i  x mod p_j" and "degree (x mod p_i) = 0" and "degree (x mod p_j) = 0"
      "(s. gcd w (x - [:s:])  w  gcd w (x - [:s:])  1)"
      using exists_vector_in_Berlekamp_subspace_dvd[OF _ _ _ pi pj _ _ _ _ w_dvd_f monic_w pi_dvd_w]
      assms by meson
  have x_in: "x  carrier W" using x by auto
  hence "(∃!a. a  B E carrier class_ring  Berlekamp_subspace.lincomb a B = x)"
    using Berlekamp_subspace.basis_criterion[OF finite_V V_in_carrier] using basis_V
    by (simp add: class_field_def)
  from this obtain a where a_Pi: "a  B E carrier class_ring"
    and lincomb_x: "Berlekamp_subspace.lincomb a B = x"
    by blast
  have fs_ss: "(WvB. a v W v) = sum (λv. smult (a v) v) B"
  proof (rule finsum_sum)
    show "finite B" by fact
    show "a  B  carrier class_ring" using a_Pi by auto
    show "B  carrier W" by (rule V_in_carrier)
  qed
  have "x mod p_i = Berlekamp_subspace.lincomb a B mod p_i" using lincomb_x by simp
  also have " ... = (WvB. a v W v) mod p_i" unfolding Berlekamp_subspace.lincomb_def ..
  also have "... = (sum (λv. smult (a v) v) B) mod p_i" unfolding fs_ss ..
  also have "... = sum (λv. smult (a v) v mod p_i) B" using finite_V poly_mod_sum by blast
  also have "... = sum (λv. smult (a v) (v mod p_i)) B" by (meson mod_smult_left)
  also have "... = sum (λv. smult (a v) (v mod p_j)) B" using all_eq by auto
  also have "... = sum (λv. smult (a v) v mod p_j) B" by (metis mod_smult_left)
  also have "... = (sum (λv. smult (a v) v) B) mod p_j"
  by (metis (mono_tags, lifting) finite_V poly_mod_sum sum.cong)
  also have "... = (WvB. a v W v) mod p_j" unfolding fs_ss ..
  also have "... = Berlekamp_subspace.lincomb a B mod p_j"
    unfolding Berlekamp_subspace.lincomb_def ..
  also have "... = x mod p_j" using lincomb_x by simp
  finally have "x mod p_i = x mod p_j" .
  thus False using x_pi_pj by contradiction
qed


lemma exists_vector_in_Berlekamp_basis_dvd:
assumes basis_V: "Berlekamp_subspace.basis B"
and finite_V: "finite B" (*This should be removed, since the Berlekamp subspace is a finite set*)
assumes finite_P: "finite P"
      and f_desc_square_free: "u = (aP. a)"
      and P: "P  {q. irreducible q  monic q}"
      and pi: "p_i  P" and pj: "p_j  P" and pi_pj: "p_i  p_j"
      and monic_f: "monic u" and sf_f: "square_free u"
      and not_irr_w: "¬ irreducible w"
      and w_dvd_f: "w dvd u" and monic_w: "monic w"
      and pi_dvd_w: "p_i dvd w" and pj_dvd_w: "p_j dvd w"
shows "v  B. v mod p_i  v mod p_j
   degree (v mod p_i) = 0
   degree (v mod p_j) = 0
― ‹This implies that the algorithm decreases the degree of the reducible polynomials in each step:›
   (s. gcd w (v - [:s:])  w  ¬ coprime w (v - [:s:]))"
proof -
  have f_not_0: "u  0" using monic_f by auto
  have irr_pi: "irreducible p_i" using pi P by fast
  have irr_pj: "irreducible p_j" using pj P by fast
  obtain v where vV: "v  B" and v_pi_pj: "v mod p_i  v mod p_j"
    using assms exists_vector_in_Berlekamp_basis_dvd_aux by blast
  have v: "v  {v. [v ^ CARD('a) = v] (mod u)}"
    using basis_V vV unfolding Berlekamp_subspace.basis_def by auto
  have deg_v_pi: "degree (v mod p_i) = 0"
    by (rule degree_u_mod_irreducibled_factor_0[OF v finite_P f_desc_square_free P pi])
  from this obtain s_i where v_pi_si: "v mod p_i = [:s_i:]" using degree_eq_zeroE by blast
  have deg_v_pj: "degree (v mod p_j) = 0"
    by (rule degree_u_mod_irreducibled_factor_0[OF v finite_P f_desc_square_free P pj])
  from this obtain s_j where v_pj_sj: "v mod p_j = [:s_j:]" using degree_eq_zeroE by blast
  have si_sj: "s_i  s_j" using v_pi_si v_pj_sj v_pi_pj by auto
  have "(s. gcd w (v - [:s:])  w  ¬ Rings.coprime w (v - [:s:]))"
  proof (rule exI[of _ s_i], rule conjI)
    have pi_dvd_v_si: "p_i dvd v - [:s_i:]" by (metis mod_eq_dvd_iff_poly mod_mod_trivial v_pi_si)
    have pj_dvd_v_sj: "p_j dvd v - [:s_j:]" by (metis mod_eq_dvd_iff_poly mod_mod_trivial v_pj_sj)
    have w_eq: "w = prod (λc. gcd w (v - [:c:])) (UNIV::'a mod_ring set)"
    proof (rule Berlekamp_gcd_step)
      show "[v ^ CARD('a) = v] (mod w)" using v cong_dvd_modulus_poly w_dvd_f by blast
      show "square_free w" by (rule square_free_factor[OF w_dvd_f sf_f])
      show "monic w" by (rule monic_w)
    qed
    show "gcd w (v - [:s_i:])  w"
      by (metis irreducibleE deg_v_pi gcd_greatest_iff irr_pj is_unit_field_poly mod_eq_dvd_iff_poly mod_poly_less neq0_conv pj_dvd_w v_pi_pj v_pi_si)
    show "¬ Rings.coprime w (v - [:s_i:])"
      using irr_pi pi_dvd_v_si pi_dvd_w 
      by (simp add: irreducibledD(1) not_coprimeI)
  qed
  thus ?thesis using v_pi_pj vV deg_v_pi deg_v_pj by auto
qed

lemma exists_bijective_linear_map_W_vec:
  assumes finite_P: "finite P"
      and u_desc_square_free: "u = (aP. a)"
      and P: "P  {q. irreducible q  monic q}"
  shows "f. linear_map class_ring W (module_vec TYPE('a mod_ring) (card P)) f
   bij_betw f (carrier W) (carrier_vec (card P)::'a mod_ring vec set)"
proof -
  let ?B="carrier_vec (card P)::'a mod_ring vec set"
  have u_not_0: "u  0" using deg_u0 degree_0 by force
  obtain m and n::nat where P_m: "P = m ` {i. i < n}" and inj_on_m: "inj_on m {i. i < n}"
    using finite_imp_nat_seg_image_inj_on[OF finite_P] by blast
  hence n: "n = card P" by (simp add: card_image)
  have degree_prod: "degree (prod m {i. i < n}) = degree u"
    by (metis P_m u_desc_square_free inj_on_m prod.reindex_cong)
  have not_zero: "i{i. i < n}. m i  0"
    using P_m u_desc_square_free u_not_0 by auto
  have deg_sum_eq: "(i{i. i < n}. degree (m i)) = degree u"
    by (metis degree_prod degree_prod_eq_sum_degree not_zero)
  have coprime_mi_mj:"i{i. i < n}. j{i. i < n}. i  j  coprime (m i) (m j)"
  proof (rule+)
    fix i j assume i: "i  {i. i < n}"
    and j: "j  {i. i < n}" and ij: "i  j"
    show "coprime (m i) (m j)"
    proof (rule coprime_polynomial_factorization[OF P finite_P])
      show "m i  P" using i P_m by auto
      show "m j  P" using j P_m by auto
      show "m i  m j" using inj_on_m i ij j unfolding inj_on_def by blast
    qed
  qed
  let ?f = "λv. vec n (λi. coeff (v mod (m i)) 0)"
  interpret vec_VS: vectorspace class_ring "(module_vec TYPE('a mod_ring) n)"
    by (rule VS_Connect.vec_vs)
  interpret linear_map class_ring W "(module_vec TYPE('a mod_ring) n)" ?f
    by (intro_locales, unfold mod_hom_axioms_def LinearCombinations.module_hom_def,
        auto simp add: vec_eq_iff module_vec_def mod_smult_left poly_mod_add_left)
  have "linear_map class_ring W (module_vec TYPE('a mod_ring) n) ?f"
    by (intro_locales)
  moreover have inj_f: "inj_on ?f (carrier W)"
  proof (rule Ke0_imp_inj, auto simp add: mod_hom.ker_def)
     show "[0 ^ CARD('a) = 0] (mod u)" by (simp add: cong_def zero_power)
     show "vec n (λi. 0) = 𝟬module_vec TYPE('a mod_ring) n" by (auto simp add: module_vec_def)
     fix x assume x: "[x ^ CARD('a) = x] (mod u)" and deg_x: "degree x < degree u"
     and v: "vec n (λi. coeff (x mod m i) 0) = 𝟬module_vec TYPE('a mod_ring) n"
     have cong_0: "i{i. i < n}. [x = (λi. 0) i] (mod m i)"
     proof (rule, unfold cong_def)
       fix i assume i: "i  {i. i < n}"
       have deg_x_mod_mi: "degree (x mod m i) = 0"
       proof (rule degree_u_mod_irreducibled_factor_0[OF _ finite_P u_desc_square_free P])
          show "x  {v. [v ^ CARD('a) = v] (mod u)}" using x by auto
          show "m i  P" using P_m i by auto
       qed
       thus "x mod m i = 0 mod m i"
        using v
        unfolding module_vec_def
        by (auto, metis i leading_coeff_neq_0 mem_Collect_eq index_vec index_zero_vec(1))
     qed
     moreover have deg_x2: "degree x < (i{i. i < n}. degree (m i))"
      using deg_sum_eq deg_x by simp
     moreover have "i{i. i < n}. [0 = (λi. 0) i] (mod m i)"
      by (auto simp add: cong_def)
     moreover have "degree 0 < (i{i. i < n}. degree (m i))"
      using degree_prod deg_sum_eq deg_u0 by force
     moreover have "∃!x. degree x < (i{i. i < n}. degree (m i))
         (i{i. i < n}. [x = (λi. 0) i] (mod m i))"
     proof (rule chinese_remainder_unique_poly[OF not_zero])
      show "0 < degree (prod m {i. i < n})"
        using deg_u0 degree_prod by linarith
     qed (insert coprime_mi_mj, auto)
     ultimately show "x = 0" by blast
  qed
  moreover have "?f ` (carrier W) = ?B"
  proof (auto simp add: image_def)
    fix xa
    show "n = card P" by (auto simp add: n)
    next
    fix x::"'a mod_ring vec" assume x: "x  carrier_vec (card P)"
    have " ∃!v. degree v < (i{i. i < n}. degree (m i))  (i{i. i < n}. [v = (λi. [:x $ i:]) i] (mod m i))"
    proof (rule chinese_remainder_unique_poly[OF not_zero])
      show "0 < degree (prod m {i. i < n})"
        using deg_u0 degree_prod by linarith
    qed (insert coprime_mi_mj, auto)
    from this obtain v where deg_v: "degree v < (i{i. i < n}. degree (m i))"
      and v_x_cong: "(i  {i. i < n}. [v = (λi. [:x $ i:]) i] (mod m i))" by auto
    show "xa. [xa ^ CARD('a) = xa] (mod u)  degree xa < degree u
       x = vec n (λi. coeff (xa mod m i) 0)"
    proof (rule exI[of _ v], auto)
      show v: "[v ^ CARD('a) = v] (mod u)"
      proof (unfold u_desc_square_free, rule coprime_cong_mult_factorization_poly[OF finite_P], auto)
        fix y assume y: "y  P" thus "irreducible y" using P by blast
        obtain i where i: "i  {i. i < n}" and mi: "y = m i" using P_m y by blast
        have "irreducible (m i)" using i P_m P by auto
        moreover have "[v = [:x $ i:]] (mod m i)" using v_x_cong i by auto
        ultimately have v_mi_eq_xi: "v mod m i = [:x $ i:]"
          by (auto simp: cong_def intro!: mod_poly_less)
        have xi_pow_xi: "[:x $ i:]^CARD('a) = [:x $ i:]" by (simp add: poly_const_pow)
        hence "(v mod m i)^CARD('a) = v mod m i" using v_mi_eq_xi by auto
        hence "(v mod m i)^CARD('a) = (v^CARD('a) mod m i)"
          by (metis mod_mod_trivial power_mod)
        thus "[v ^ CARD('a) = v] (mod y)" unfolding mi cong_def v_mi_eq_xi xi_pow_xi by simp
      next
        fix p1 p2 assume "p1  P" and "p2  P" and "p1  p2"
        then show "Rings.coprime p1 p2"
          using coprime_polynomial_factorization[OF P finite_P] by auto
      qed
      show "degree v < degree u" using deg_v deg_sum_eq degree_prod by presburger
      show "x = vec n (λi. coeff (v mod m i) 0)"
      proof (unfold vec_eq_iff, rule conjI)
         show "dim_vec x = dim_vec (vec n (λi. coeff (v mod m i) 0))" using x n by simp
         show "i<dim_vec (vec n (λi. coeff (v mod m i) 0)). x $ i = vec n (λi. coeff (v mod m i) 0) $ i"
         proof (auto)
           fix i assume i: "i < n"
           have deg_mi: "irreducible (m i)" using i P_m P by auto
           have deg_v_mi: "degree (v mod m i) = 0"
           proof (rule degree_u_mod_irreducibled_factor_0[OF _ finite_P u_desc_square_free P])
              show "v  {v. [v ^ CARD('a) = v] (mod u)}" using v by fast
              show "m i  P" using P_m i by auto
           qed
           have "v mod m i = [:x $ i:] mod m i" using v_x_cong i unfolding cong_def by auto
           also have "... = [:x $ i:]" using deg_mi by (auto intro!: mod_poly_less)
           finally show "x $ i = coeff (v mod m i) 0" by simp
         qed
      qed
    qed
  qed
  ultimately show ?thesis unfolding bij_betw_def n by auto
qed

lemma fin_dim_kernel_berlekamp: "V.fin_dim"
proof -
  have "finite (set (find_base_vectors (berlekamp_resulting_mat u)))" by auto
  moreover have "set (find_base_vectors (berlekamp_resulting_mat u))  carrier V"
  and "V.gen_set (set (find_base_vectors (berlekamp_resulting_mat u)))"
    using berlekamp_resulting_mat_basis[of u] unfolding V.basis_def by auto
  ultimately show ?thesis unfolding V.fin_dim_def by auto
qed

lemma Berlekamp_subspace_fin_dim: "Berlekamp_subspace.fin_dim"
proof (rule linear_map.surj_fin_dim[OF linear_map_Poly_list_of_vec'])
  show "(Poly  list_of_vec) ` carrier V = carrier W"
    using surj_Poly_list_of_vec[OF deg_u0] by auto
  show "V.fin_dim" by (rule fin_dim_kernel_berlekamp)
qed

context
  fixes P
  assumes finite_P: "finite P"
  and u_desc_square_free: "u = (aP. a)"
  and P: "P  {q. irreducible q  monic q}"
begin

interpretation RV: vec_space "TYPE('a mod_ring)" "card P" .

lemma Berlekamp_subspace_eq_dim_vec: "Berlekamp_subspace.dim = RV.dim"
proof -
  obtain f where lm_f: "linear_map class_ring W (module_vec TYPE('a mod_ring) (card P)) f"
  and bij_f: "bij_betw f (carrier W) (carrier_vec (card P)::'a mod_ring vec set)"
    using exists_bijective_linear_map_W_vec[OF finite_P u_desc_square_free P] by blast
  show ?thesis
  proof (rule linear_map.dim_eq[OF lm_f Berlekamp_subspace_fin_dim])
    show "inj_on f (carrier W)" by (rule bij_betw_imp_inj_on[OF bij_f])
    show " f ` carrier W = carrier RV.V" using bij_f unfolding bij_betw_def by auto
  qed
qed


lemma Berlekamp_subspace_dim: "Berlekamp_subspace.dim = card P"
  using Berlekamp_subspace_eq_dim_vec RV.dim_is_n by simp

corollary card_berlekamp_basis_number_factors: "card (set (berlekamp_basis u)) = card P"
  unfolding Berlekamp_subspace_dim[symmetric]
  by (rule Berlekamp_subspace.dim_basis[symmetric], auto simp add: berlekamp_basis_basis)


lemma length_berlekamp_basis_numbers_factors: "length (berlekamp_basis u) = card P"
  using card_set_berlekamp_basis card_berlekamp_basis_number_factors by auto


end
end
end
end

context
  assumes "SORT_CONSTRAINT('a :: prime_card)"
begin

context
  fixes f :: "'a mod_ring poly" and n
  assumes sf: "square_free f"
  and n: "n = length (berlekamp_basis f)"
  and monic_f: "monic f"
begin
lemma berlekamp_basis_length_factorization: assumes f: "f = prod_list us"
  and d: " u. u  set us  degree u > 0"
  shows "length us  n"
proof (cases "degree f = 0")
  case True
  have "us = []"
  proof (rule ccontr)
    assume "us  []"
    from this obtain u where u: "u  set us" by fastforce
    hence deg_u: "degree u > 0" using d by auto
    have "degree f = degree (prod_list us)" unfolding f ..
    also have "... = sum_list (map degree us)"
    proof (rule degree_prod_list_eq)
      fix p assume p: "p  set us"
      show "p  0" using d[OF p] degree_0 by auto
    qed
    also have " ...  degree u" by (simp add: member_le_sum_list u)
    finally have "degree f > 0" using deg_u by auto
    thus False using True by auto
  qed
  thus ?thesis by simp
next
  case False
  hence f_not_0: "f  0" using degree_0 by fastforce
  obtain P where fin_P: "finite P" and f_P: "f = P" and P: "P  {p. irreducible p  monic p}"
    using monic_square_free_irreducible_factorization[OF monic_f sf] by auto
  have n_card_P: "n = card P"
    using P False f_P fin_P length_berlekamp_basis_numbers_factors n by blast
  have distinct_us: "distinct us" using d f sf square_free_prod_list_distinct by blast
  let ?us'="(map normalize us)"
  have distinct_us': "distinct ?us'"
  proof (auto simp add: distinct_map)
    show "distinct us" by (rule distinct_us)
    show "inj_on normalize (set us)"
    proof (auto simp add: inj_on_def, rule ccontr)
       fix x y assume x: "x  set us" and y: "y  set us" and n: "normalize x = normalize y"
       and x_not_y: "x  y"
       from normalize_eq_imp_smult[OF n]
       obtain c where c0: "c  0" and y_smult: "y = smult c x" by blast
       have sf_xy: "square_free (x*y)"
       proof (rule square_free_factor[OF _ sf])
          have "x*y = prod_list [x,y]" by simp
          also have "... dvd prod_list us"
            by (rule prod_list_dvd_prod_list_subset, auto simp add: x y x_not_y distinct_us)
          also have "... = f" unfolding f ..
          finally show "x * y dvd f" .
       qed
       have "x * y = smult c (x*x)" using y_smult mult_smult_right by auto
       hence sf_smult: "square_free (smult c (x*x))" using sf_xy by auto
       have "x*x dvd (smult c (x*x))" by (simp add: dvd_smult)
       hence "¬ square_free (smult c (x*x))"
        by (metis d square_free_def x)
       thus "False" using sf_smult by contradiction
    qed
  qed
  have length_us_us': "length us = length ?us'" by simp
  have f_us': "f = prod_list ?us'"
  proof -
    have "f = normalize f" using monic_f f_not_0 by (simp add: normalize_monic)
    also have "... = prod_list ?us'" by (unfold f, rule prod_list_normalize[of us])
    finally show ?thesis .
  qed
  have "Q. prod_list Q = prod_list ?us'  length ?us'  length Q
            (u. u  set Q  irreducible u  monic u)"
  proof (rule exists_factorization_prod_list)
    show "degree (prod_list ?us') > 0" using False f_us' by auto
    show "square_free (prod_list ?us')" using f_us' sf by auto
    fix u assume u: "u  set ?us'"
    have u_not0: "u  0" using d u degree_0 by fastforce
    have "degree u > 0" using d u by auto
    moreover have "monic u" using u monic_normalize[OF u_not0] by auto
    ultimately show "degree u > 0  monic u" by simp
  qed
  from this obtain Q
  where Q_us': "prod_list Q = prod_list ?us'"
  and length_us'_Q: "length ?us'  length Q"
  and Q: "(u. u  set Q  irreducible u  monic u)"
  by blast
  have distinct_Q: "distinct Q"
  proof (rule square_free_prod_list_distinct)
    show "square_free (prod_list Q)" using Q_us' f_us' sf by auto
    show "u. u  set Q  degree u > 0" using Q irreducible_degree_field by auto
  qed
  have set_Q_P: "set Q = P"
  proof (rule monic_factorization_uniqueness)
    show "(set Q) = P" using Q_us'
      by (metis distinct_Q f_P f_us' list.map_ident prod.distinct_set_conv_list)
  qed (insert P Q fin_P, auto)
  hence "length Q = card P" using distinct_Q distinct_card by fastforce
  have "length us = length ?us'" by (rule length_us_us')
  also have "...  length Q" using length_us'_Q by auto
  also have "... = card (set Q)" using distinct_card[OF distinct_Q] by simp
  also have "... = card P" using set_Q_P by simp
  finally show ?thesis using n_card_P by simp
qed

lemma berlekamp_basis_irreducible: assumes f: "f = prod_list us"
  and n_us: "length us = n"
  and us: " u. u  set us  degree u > 0"
  and u: "u  set us"
  shows "irreducible u"
proof (fold irreducible_connect_field, intro irreducibledI[OF us[OF u]])
  fix q r :: "'a mod_ring poly"
  assume dq: "degree q > 0" and qu: "degree q < degree u" and dr: "degree r > 0" and uqr: "u = q * r"
  with us[OF u] have q: "q  0" and r: "r  0" by auto
  from split_list[OF u] obtain xs ys where id: "us = xs @ u # ys" by auto
  let ?us = "xs @ q # r # ys"
  have f: "f = prod_list ?us" unfolding f id uqr by simp
  {
    fix x
    assume "x  set ?us"
    with us[unfolded id] dr dq have "degree x > 0" by auto
  }
  from berlekamp_basis_length_factorization[OF f this]
  have "length ?us  n" by simp
  also have " = length us" unfolding n_us by simp
  also have " < length ?us" unfolding id by simp
  finally show False by simp
qed
end

lemma not_irreducible_factor_yields_prime_factors:
  assumes uf: "u dvd (f :: 'b :: {field_gcd} poly)" and fin: "finite P"
      and fP: "f = P" and P: "P  {q. irreducible q  monic q}"
    and u: "degree u > 0" "¬ irreducible u"
  shows " pi pj. pi  P  pj  P  pi  pj  pi dvd u  pj dvd u"
proof -
  from finite_distinct_list[OF fin] obtain ps where Pps: "P = set ps" and dist: "distinct ps" by auto
  have fP: "f = prod_list ps" unfolding fP Pps using dist
    by (simp add: prod.distinct_set_conv_list)
  note P = P[unfolded Pps]
  have "set ps  P" unfolding Pps by auto
  from uf[unfolded fP] P dist this
  show ?thesis
  proof (induct ps)
    case Nil
    with u show ?case using divides_degree[of u 1] by auto
  next
    case (Cons p ps)
    from Cons(3) have ps: "set ps  {q. irreducible q  monic q}" by auto
    from Cons(2) have dvd: "u dvd p * prod_list ps" by simp
    obtain k where gcd: "u = gcd p u * k" by (meson dvd_def gcd_dvd2)
    from Cons(3) have *: "monic p" "irreducible p" "p  0" by auto
    from monic_irreducible_gcd[OF *(1), of u] *(2)
    have "gcd p u = 1  gcd p u = p" by auto
    thus ?case
    proof
      assume "gcd p u = 1"
      then have "Rings.coprime p u"
        by (rule gcd_eq_1_imp_coprime)
      with dvd have "u dvd prod_list ps"
        using coprime_dvd_mult_right_iff coprime_imp_coprime by blast
      from Cons(1)[OF this ps] Cons(4-5) show ?thesis by auto
    next
      assume "gcd p u = p"
      with gcd have upk: "u = p * k" by auto
      hence p: "p dvd u" by auto
      from dvd[unfolded upk] *(3) have kps: "k dvd prod_list ps" by auto
      from dvd u * have dk: "degree k > 0"
        by (metis gr0I irreducible_mult_unit_right is_unit_iff_degree mult_zero_right upk)
      from ps kps have " q  set ps. q dvd k"
      proof (induct ps)
        case Nil
        with dk show ?case using divides_degree[of k 1] by auto
      next
        case (Cons p ps)
        from Cons(3) have dvd: "k dvd p * prod_list ps" by simp
        obtain l where gcd: "k = gcd p k * l" by (meson dvd_def gcd_dvd2)
        from Cons(2) have *: "monic p" "irreducible p" "p  0" by auto
        from monic_irreducible_gcd[OF *(1), of k] *(2)
        have "gcd p k = 1  gcd p k = p" by auto
        thus ?case
        proof
          assume "gcd p k = 1"
          with dvd have "k dvd prod_list ps"
            by (metis dvd_triv_left gcd_greatest_mult mult.left_neutral)
          from Cons(1)[OF _ this] Cons(2) show ?thesis by auto
        next
          assume "gcd p k = p"
          with gcd have upk: "k = p * l" by auto
          hence p: "p dvd k" by auto
          thus ?thesis by auto
        qed
      qed
      then obtain q where q: "q  set ps" and dvd: "q dvd k" by auto
      from dvd upk have qu: "q dvd u" by auto
      from Cons(4) q have "p  q" by auto
      thus ?thesis using q p qu Cons(5) by auto
    qed
  qed
qed

lemma berlekamp_factorization_main:
  fixes f::"'a mod_ring poly"
  assumes sf_f: "square_free f"
    and vs: "vs = vs1 @ vs2"
    and vsf: "vs = berlekamp_basis f"
    and n_bb: "n = length (berlekamp_basis f)"
    and n: "n = length us1 + n2"
    and us: "us = us1 @ berlekamp_factorization_main d divs vs2 n2"
    and us1: " u. u  set us1  monic u  irreducible u"
    and divs: " d. d  set divs  monic d  degree d > 0"
    and vs1: " u v i. v  set vs1  u  set us1  set divs
       i < CARD('a)  gcd u (v - [:of_nat i:])  {1,u}"
    and f: "f = prod_list (us1 @ divs)"
    and deg_f: "degree f > 0"
    and d: " g. g dvd f  degree g = d  irreducible g" 
  shows "f = prod_list us  ( u  set us. monic u  irreducible u)"
proof -
  have mon_f: "monic f" unfolding f
    by (rule monic_prod_list, insert divs us1, auto)
  from monic_square_free_irreducible_factorization[OF mon_f sf_f] obtain P where
    P: "finite P" "f =  P" "P  {q. irreducible q  monic q}" by auto
  hence f0: "f  0" by auto
  show ?thesis
    using vs n us divs f us1 vs1
  proof (induct vs2 arbitrary: divs n2 us1 vs1)
    case (Cons v vs2)
    show ?case
    proof (cases "v = 1")
      case False
      from Cons(2) vsf have v: "v  set (berlekamp_basis f)" by auto
      from berlekamp_basis_eq_8[OF this] have vf: "[v ^ CARD('a) = v] (mod f)" .
      let ?gcd = "λ u i. gcd u (v - [:of_int i:])"
      let ?gcdn = "λ u i. gcd u (v - [:of_nat i:])"
      let ?map = "λ u. (map (λ i. ?gcd u i) [0 ..< CARD('a)])"
      define udivs where "udivs  λ u. filter (λ w. w  1) (?map u)"
      {
        obtain xs where xs: "[0..<CARD('a)] = xs" by auto
        have "udivs = (λ u. [w. i  [0 ..< CARD('a)], w  [?gcd u i], w  1])"
          unfolding udivs_def xs
          by (intro ext, auto simp: o_def, induct xs, auto)
      } note udivs_def' = this
      define facts where "facts  [ w . u  divs, w  udivs u]"
      {
        fix u
        assume u: "u  set divs"
        then obtain bef aft where divs: "divs = bef @ u # aft" by (meson split_list)
        from Cons(5)[OF u] have mon_u: "monic u" by simp
        have uf: "u dvd f" unfolding Cons(6) divs by auto
        from vf uf have vu: "[v ^ CARD('a) = v] (mod u)" by (rule cong_dvd_modulus_poly)
        from square_free_factor[OF uf sf_f] have sf_u: "square_free u" .
        let ?g = "?gcd u"
        from mon_u have u0: "u  0" by auto
        have "u = (cUNIV. gcd u (v - [:c:]))"
          using Berlekamp_gcd_step[OF vu mon_u sf_u] .
        also have " = (i  {0..< int CARD('a)}. ?g i)"
          by (rule sym, rule prod.reindex_cong[OF to_int_mod_ring_hom.inj_f range_to_int_mod_ring[symmetric]],
          simp add: of_int_of_int_mod_ring)
        finally have u_prod: "u = (i  {0..< int CARD('a)}. ?g i)" .
        let ?S = "{0..<int CARD('a)} - {i. ?g i = 1}"
        {
          fix i
          assume "i  ?S"
          hence "?g i  1" by auto
          moreover have mgi: "monic (?g i)" by (rule poly_gcd_monic, insert u0, auto)
          ultimately have "degree (?g i) > 0"
            using monic_degree_0 by blast
          note this mgi
        } note gS = this

        have int_set: "int ` set [0..<CARD('a)] = {0 ..< int CARD('a)}"
          by (simp add: image_int_atLeastLessThan)

        have inj: "inj_on ?g ?S" unfolding inj_on_def
        proof (intro ballI impI)
          fix i j
          assume i: "i  ?S" and j: "j  ?S" and gij: "?g i = ?g j"
          show "i = j"
          proof (rule ccontr)
            define S where "S = {0..<int CARD('a)} - {i,j}"
            have id: "{0..<int CARD('a)} = (insert i (insert j S))" and S: "i  S" "j  S" "finite S"
              using i j unfolding S_def by auto
            assume ij: "i  j"
            have "u = (i  {0..< int CARD('a)}. ?g i)" by fact
            also have " = ?g i * ?g j * (i  S. ?g i)"
              unfolding id using S ij by auto
            also have " = ?g i * ?g i * (i  S. ?g i)" unfolding gij by simp
            finally have dvd: "?g i * ?g i dvd u" unfolding dvd_def by auto
            with sf_u[unfolded square_free_def, THEN conjunct2, rule_format, OF gS(1)[OF i]]
            show False by simp
          qed
        qed

        have "u = (i  {0..< int CARD('a)}. ?g i)" by fact
        also have " = (i  ?S. ?g i)"
          by (rule sym, rule prod.setdiff_irrelevant, auto)
        also have " =  (set (udivs u))" unfolding udivs_def set_filter set_map
          by (rule sym, rule prod.reindex_cong[of ?g, OF inj _ refl], auto simp: int_set[symmetric])
        finally have u_udivs: "u = (set (udivs u))" .
        {
          fix w
          assume mem: "w  set (udivs u)"
          then obtain i where w: "w = ?g i" and i: "i  ?S"
            unfolding udivs_def set_filter set_map int_set by auto
          have wu: "w dvd u" by (simp add: w)
          let ?v = "λ j. v - [:of_nat j:]"
          define j where "j = nat i"
          from i have j: "of_int i = (of_nat j :: 'a mod_ring)" "j < CARD('a)" unfolding j_def by auto
          from gS[OF i, folded w] have *: "degree w > 0" "monic w" "w  0" by auto
          from w have "w dvd ?v j" using j by simp
          hence gcdj: "?gcdn w j = w" by (metis gcd.commute gcd_left_idem j(1) w)
          {
            fix j'
            assume j': "j' < CARD('a)"
            have "?gcdn w j'  {1,w}"
            proof (rule ccontr)
              assume not: "?gcdn w j'  {1,w}"
              with gcdj have neq: "int j'  int j" by auto
              (* next step will yield contradiction to square_free u *)
              let ?h = "?gcdn w j'"
              from *(3) not have deg: "degree ?h > 0"
                using monic_degree_0 poly_gcd_monic by auto
              have hw: "?h dvd w" by auto
              have "?h dvd ?gcdn u j'" using wu using dvd_trans by auto
              also have "?gcdn u j' = ?g j'" by simp
              finally have hj': "?h dvd ?g j'" by auto
              from divides_degree[OF this] deg u0 have degj': "degree (?g j') > 0" by auto
              hence j'1: "?g j'  1" by auto
              with j' have mem': "?g j'  set (udivs u)" unfolding udivs_def by auto
              from degj' j' have j'S: "int j'  ?S" by auto
              from i j have jS: "int j  ?S" by auto
              from inj_on_contraD[OF inj neq j'S jS]
              have neq: "w  ?g j'" using w j by auto
              have cop: "¬ coprime w (?g j')" using hj' hw deg
                by (metis coprime_not_unit_not_dvd poly_dvd_1 Nat.neq0_conv)
              obtain w' where w': "?g j' = w'" by auto
              from u_udivs sf_u have "square_free ((set (udivs u)))" by simp
              from square_free_prodD[OF this finite_set mem mem'] cop neq
              show False by simp
            qed
          }
          from gS[OF i, folded w] i this
          have "degree w > 0" "monic w" " j. j < CARD('a)  ?gcdn w j  {1,w}" by auto
        } note udivs = this
        let ?is = "filter (λ i. ?g i  1) (map int [0 ..< CARD('a)])"
        have id: "udivs u = map ?g ?is"
          unfolding udivs_def filter_map o_def ..
        have dist: "distinct (udivs u)" unfolding id distinct_map
        proof (rule conjI[OF distinct_filter], unfold distinct_map)
          have "?S = set ?is" unfolding int_set[symmetric] by auto
          thus "inj_on ?g (set ?is)" using inj by auto
        qed (auto simp: inj_on_def)
        from u_udivs prod.distinct_set_conv_list[OF dist, of id]
        have "prod_list (udivs u) = u" by auto
        note udivs this dist
      } note udivs = this
      have facts: "facts = concat (map udivs divs)"
        unfolding facts_def by auto
      obtain lin nonlin where part: "List.partition (λ q. degree q = d) facts = (lin,nonlin)" 
        by force
      from Cons(6) have "f = prod_list us1 * prod_list divs" by auto
      also have "prod_list divs = prod_list facts" unfolding facts using udivs(4)
        by (induct divs, auto)
      finally have f: "f = prod_list us1 * prod_list facts" .
      note facts' = facts
      {
        fix u
        assume u: "u  set facts"
        from u[unfolded facts] obtain u' where u': "u'  set divs" and u: "u  set (udivs u')" by auto
        from u' udivs(1-2)[OF u' u] prod_list_dvd[OF u, unfolded udivs(4)[OF u']]
        have "degree u > 0" "monic u" " u'  set divs. u dvd u'" by auto
      } note facts = this
      have not1: "(v = 1) = False" using False by auto
      have "us = us1 @ (if length divs = n2 then divs
          else let (lin, nonlin) = List.partition (λq. degree q = d) facts
               in lin @ berlekamp_factorization_main d nonlin vs2 (n2 - length lin))"
        unfolding Cons(4) facts_def udivs_def' berlekamp_factorization_main.simps Let_def not1 if_False
        by (rule arg_cong[where f = "λ x. us1 @ x"], rule if_cong, simp_all) (* takes time *)
      hence res: "us = us1 @ (if length divs = n2 then divs else
               lin @ berlekamp_factorization_main d nonlin vs2 (n2 - length lin))"
        unfolding part by auto
      show ?thesis
      proof (cases "length divs = n2")
        case False
        with res have us: "us = (us1 @ lin) @ berlekamp_factorization_main d nonlin vs2 (n2 - length lin)"
          by auto
        from Cons(2) have vs: "vs = (vs1 @ [v]) @ vs2" by auto
        have f: "f = prod_list ((us1 @ lin) @ nonlin)"
          unfolding f using prod_list_partition[OF part] by simp
        {
          fix u
          assume "u  set ((us1 @ lin) @ nonlin)"
          with part have "u  set facts  set us1" by auto
          with facts Cons(7) have "degree u > 0" by (auto simp: irreducible_degree_field)
        } note deg = this
        from berlekamp_basis_length_factorization[OF sf_f n_bb mon_f f deg, unfolded Cons(3)]
        have "n2  length lin" by auto
        hence n: "n = length (us1 @ lin) + (n2 - length lin)"
          unfolding Cons(3) by auto
        show ?thesis
        proof (rule Cons(1)[OF vs n us _ f])
          fix u
          assume "u  set nonlin"
          with part have "u  set facts" by auto
          from facts[OF this] show "monic u  degree u > 0" by auto
        next
          fix u
          assume u: "u  set (us1 @ lin)"
          {
            assume *: "¬ (monic u  irreducibled u)"
            with Cons(7) u have "u  set lin" by auto
            with part have uf: "u  set facts" and deg: "degree u = d" by auto
            from facts[OF uf] obtain u' where "u'  set divs" and uu': "u dvd u'" by auto
            from this(1) have "u' dvd f" unfolding Cons(6) using prod_list_dvd[of u'] by auto
            with uu' have "u dvd f" by (rule dvd_trans)
            from facts[OF uf] d[OF this deg] * have False by auto
          }
          thus "monic u  irreducible u" by auto
        next
          fix w u i
          assume w: "w  set (vs1 @ [v])"
            and u: "u  set (us1 @ lin)  set nonlin"
            and i: "i < CARD('a)"
          from u part have u: "u  set us1  set facts" by auto
          show "gcd u (w - [:of_nat i:])  {1, u}"
          proof (cases "u  set us1")
            case True
            from Cons(7)[OF this] have "monic u" "irreducible u" by auto
            thus ?thesis by (rule monic_irreducible_gcd)
          next
            case False
            with u have u: "u  set facts" by auto
            show ?thesis
            proof (cases "w = v")
              case True
              from u[unfolded facts'] obtain u' where u: "u  set (udivs u')"
                and u': "u'  set divs" by auto
              from udivs(3)[OF u' u i] show ?thesis unfolding True .
            next
              case False
              with w have w: "w  set vs1" by auto
              from u obtain u' where u': "u'  set divs" and dvd: "u dvd u'"
                using facts(3)[of u] dvd_refl[of u] by blast
              from w have "w  set vs1  w = v" by auto
              from facts(1-2)[OF u] have u: "monic u" by auto
              from Cons(8)[OF w _ i] u'
              have "gcd u' (w - [:of_nat i:])  {1, u'}" by auto
              with dvd u show ?thesis by (rule monic_gcd_dvd)
            qed
          qed
        qed
      next
        case True
        with res have us: "us = us1 @ divs" by auto
        from Cons(3) True have n: "n = length us" unfolding us by auto
        show ?thesis unfolding us[symmetric]
        proof (intro conjI ballI)
          show f: "f = prod_list us" unfolding us using Cons(6) by simp
          {
            fix u
            assume "u  set us"
            hence "degree u > 0" using Cons(5) Cons(7)[unfolded irreducibled_def]
              unfolding us by (auto simp: irreducible_degree_field)
          } note deg = this
          fix u
          assume u: "u  set us"
          thus "monic u" unfolding us using Cons(5) Cons(7) by auto
          show "irreducible u"
            by (rule berlekamp_basis_irreducible[OF sf_f n_bb mon_f f n[symmetric] deg u])
        qed
      qed
    next
      case True (* v = 1 *)
      with Cons(4) have us: "us = us1 @ berlekamp_factorization_main d divs vs2 n2" by simp
      from Cons(2) True have vs: "vs = (vs1 @ [1]) @ vs2" by auto
      show ?thesis
      proof (rule Cons(1)[OF vs Cons(3) us Cons(5-7)], goal_cases)
        case (3 v u i)
        show ?case
        proof (cases "v = 1")
          case False
          with 3 Cons(8)[of v u i] show ?thesis by auto
        next
          case True
          hence deg: "degree (v - [: of_nat i :]) = 0"
            by (metis (no_types, hide_lams) degree_pCons_0 diff_pCons diff_zero pCons_one)
          from 3(2) Cons(5,7)[of u] have "monic u" by auto
          from gcd_monic_constant[OF this deg] show ?thesis .
        qed
      qed
    qed
  next
    case Nil
    with vsf have vs1: "vs1 = berlekamp_basis f" by auto
    from Nil(3) have us: "us = us1 @ divs" by auto
    from Nil(4,6) have md: " u. u  set us  monic u  degree u > 0"
      unfolding us by (auto simp: irreducible_degree_field)
    from Nil(7)[unfolded vs1] us
    have no_further_splitting_possible:
      " u v i. v  set (berlekamp_basis f)  u  set us
       i < CARD('a)  gcd u (v - [:of_nat i:])  {1, u}" by auto
    from Nil(5) us have prod: "f = prod_list us" by simp
    show ?case
    proof (intro conjI ballI)
      fix u
      assume u: "u  set us"
      from md[OF this] have mon_u: "monic u" and deg_u: "degree u > 0" by auto
      from prod u have uf: "u dvd f" by (simp add: prod_list_dvd)
      from monic_square_free_irreducible_factorization[OF mon_f sf_f] obtain P where
        P: "finite P" "f = P" "P  {q. irreducible q  monic q}" by auto
      show "irreducible u"
      proof (rule ccontr)
        assume irr_u: "¬ irreducible u"
        from not_irreducible_factor_yields_prime_factors[OF uf P deg_u this]
        obtain pi pj where pij: "pi  P" "pj  P" "pi  pj" "pi dvd u" "pj dvd u" by blast
        from exists_vector_in_Berlekamp_basis_dvd[OF
          deg_f berlekamp_basis_basis[OF deg_f, folded vs1] finite_set
          P pij(1-3) mon_f sf_f irr_u uf mon_u pij(4-5), unfolded vs1]
        obtain v s where v: "v  set (berlekamp_basis f)" 
          and gcd: "gcd u (v - [:s:])  {1,u}" using is_unit_gcd by auto
        from surj_of_nat_mod_ring[of s] obtain i where i: "i < CARD('a)" and s: "s = of_nat i" by auto
        from no_further_splitting_possible[OF v u i] gcd[unfolded s]
        show False by auto
      qed
    qed (insert prod md, auto)
  qed
qed

lemma berlekamp_monic_factorization:
  fixes f::"'a mod_ring poly"
  assumes sf_f: "square_free f"
    and us: "berlekamp_monic_factorization d f = us"
    and d: " g. g dvd f  degree g = d  irreducible g" 
    and deg: "degree f > 0" 
    and mon: "monic f" 
  shows "f = prod_list us  ( u  set us. monic u  irreducible u)"
proof -
  from us[unfolded berlekamp_monic_factorization_def Let_def] deg
  have us: "us = [] @ berlekamp_factorization_main d [f] (berlekamp_basis f) (length (berlekamp_basis f))"
    by (auto)
  have id: "berlekamp_basis f = [] @ berlekamp_basis f"
    "length (berlekamp_basis f) = length [] + length (berlekamp_basis f)"
    "f = prod_list ([] @ [f])"
    by auto
  show "f = prod_list us  ( u  set us. monic u  irreducible u)"
    by (rule berlekamp_factorization_main[OF sf_f id(1) refl refl id(2) us _ _ _ id(3)],
    insert mon deg d, auto)
qed
end

end

Theory Distinct_Degree_Factorization

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹Distinct Degree Factorization›
theory Distinct_Degree_Factorization
imports 
  Finite_Field
  Polynomial_Factorization.Square_Free_Factorization 
  Berlekamp_Type_Based
begin

definition factors_of_same_degree :: "nat  'a :: field poly  bool" where
  "factors_of_same_degree i f = (i  0  degree f  0  monic f  ( g. irreducible g  g dvd f  degree g = i))" 

lemma factors_of_same_degreeD: assumes "factors_of_same_degree i f"
  shows "i  0" "degree f  0" "monic f" "g dvd f  irreducible g = (degree g = i)" 
proof -
  note * = assms[unfolded factors_of_same_degree_def]
  show i: "i  0" and f: "degree f  0" "monic f" using * by auto
  assume gf: "g dvd f" 
  with * have "irreducible g  degree g = i" by auto
  moreover
  {
    assume **: "degree g = i" "¬ irreducible g" 
    with irreducibled_factor[of g] i obtain h1 h2 where irr: "irreducible h1" and gh: "g = h1 * h2" 
      and deg_h2: "degree h2 < degree g" by auto
    from ** i have g0: "g  0" by auto
    from gf gh g0 have "h1 dvd f" using dvd_mult_left by blast
    from * f this irr have deg_h: "degree h1 = i" by auto
    from arg_cong[OF gh, of degree] g0 have "degree g = degree h1 + degree h2"
      by (simp add: degree_mult_eq gh)
    with **(1) deg_h have "degree h2 = 0" by auto
    from degree0_coeffs[OF this] obtain c where h2: "h2 = [:c:]" by auto
    with gh g0 have g: "g = smult c h1" "c  0" by auto
    with irr **(2) irreducible_smult_field[of c h1] have False by auto
  }
  ultimately show "irreducible g = (degree g = i)" by auto
qed

(* Exercise 16 in Knuth, pages 457 and 682 *)

hide_const order
hide_const up_ring.monom

(*This theorem is field.finite_field_mult_group_has_gen but adding the order of the element.*)
theorem (in field) finite_field_mult_group_has_gen2:
  assumes finite:"finite (carrier R)"
  shows "a  carrier (mult_of R). group.ord (mult_of R) a = order (mult_of R) 
   carrier (mult_of R) = {a[^]i | i::nat . i  UNIV}"
proof -
  note mult_of_simps[simp]
  have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of)

  interpret G: group "mult_of R" rewrites
      "([^]mult_of R) = (([^]) :: _  nat  _)" and "𝟭mult_of R = 𝟭"
    by (rule field_mult_group) (simp_all add: fun_eq_iff nat_pow_def)

  let ?N = "λ x . card {a  carrier (mult_of R). group.ord (mult_of R) a  = x}"
  have "0 < order R - 1" unfolding Coset.order_def using card_mono[OF finite, of "{𝟬, 𝟭}"] by simp
  then have *: "0 < order (mult_of R)" using assms by (simp add: order_mult_of)
  have fin: "finite {d. d dvd order (mult_of R) }" using dvd_nat_bounds[OF *] by force

  have "(d | d dvd order (mult_of R). ?N d)
      = card (UN d:{d . d dvd order (mult_of R) }. {a  carrier (mult_of R). group.ord (mult_of R) a  = d})"
      (is "_ = card ?U")
    using fin finite by (subst card_UN_disjoint) auto
  also have "?U = carrier (mult_of R)"
  proof
    { fix x assume x:"x  carrier (mult_of R)"
      hence x':"xcarrier (mult_of R)" by simp
      then have "group.ord (mult_of R) x dvd order (mult_of R)"
          using finite' G.ord_dvd_group_order[OF x'] by (simp add: order_mult_of)
      hence "x  ?U" using dvd_nat_bounds[of "order (mult_of R)" "group.ord (mult_of R) x"] x by blast
    } thus "carrier (mult_of R)  ?U" by blast
  qed auto
  also have "card ... = Coset.order (mult_of R)"
    using order_mult_of finite' by (simp add: Coset.order_def)
  finally have sum_Ns_eq: "(d | d dvd order (mult_of R). ?N d) = order (mult_of R)" .

  { fix d assume d:"d dvd order (mult_of R)"
    have "card {a  carrier (mult_of R). group.ord (mult_of R) a = d}  phi' d"
    proof cases
      assume "card {a  carrier (mult_of R). group.ord (mult_of R) a = d} = 0" thus ?thesis by presburger
      next
      assume "card {a  carrier (mult_of R). group.ord (mult_of R) a = d}  0"
      hence "a  carrier (mult_of R). group.ord (mult_of R) a = d" by (auto simp: card_eq_0_iff)
      thus ?thesis using num_elems_of_ord_eq_phi'[OF finite d] by auto
    qed
  }
  hence all_le:"i. i  {d. d dvd order (mult_of R) }
         (λi. card {a  carrier (mult_of R). group.ord (mult_of R) a = i}) i  (λi. phi' i) i" by fast
  hence le:"(i | i dvd order (mult_of R). ?N i)
             (i | i dvd order (mult_of R). phi' i)"
            using sum_mono[of "{d .  d dvd order (mult_of R)}"
                  "λi. card {a  carrier (mult_of R). group.ord (mult_of R) a = i}"] by presburger
  have "order (mult_of R) = (d | d dvd order (mult_of R). phi' d)" using *
    by (simp add: sum_phi'_factors)
  hence eq:"(i | i dvd order (mult_of R). ?N i)
          = (i | i dvd order (mult_of R). phi' i)" using le sum_Ns_eq by presburger
  have "i. i  {d. d dvd order (mult_of R) }  ?N i = (λi. phi' i) i"
  proof (rule ccontr)
    fix i
    assume i1:"i  {d. d dvd order (mult_of R)}" and "?N i  phi' i"
    hence "?N i = 0"
      using num_elems_of_ord_eq_phi'[OF finite, of i] by (auto simp: card_eq_0_iff)
    moreover  have "0 < i" using * i1 by (simp add: dvd_nat_bounds[of "order (mult_of R)" i])
    ultimately have "?N i < phi' i" using phi'_nonzero by presburger
    hence "(i | i dvd order (mult_of R). ?N i)
         < (i | i dvd order (mult_of R). phi' i)"
      using sum_strict_mono_ex1[OF fin, of "?N" "λ i . phi' i"]
            i1 all_le by auto
    thus False using eq by force
  qed
  hence "?N (order (mult_of R)) > 0" using * by (simp add: phi'_nonzero)
  then obtain a where a:"a  carrier (mult_of R)" and a_ord:"group.ord (mult_of R) a = order (mult_of R)"
    by (auto simp add: card_gt_0_iff)
  hence set_eq:"{a[^]i | i::nat. i  UNIV} = (λx. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}"
    using G.ord_elems[OF finite'] by auto
  have card_eq:"card ((λx. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 .. group.ord (mult_of R) a - 1}"
    by (intro card_image G.ord_inj finite' a)
  hence "card ((λ x . a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 ..order (mult_of R) - 1}"
    using assms by (simp add: card_eq a_ord)
  hence card_R_minus_1:"card {a[^]i | i::nat. i  UNIV} =  order (mult_of R)"
    using * by (subst set_eq) auto
  have **:"{a[^]i | i::nat. i  UNIV}  carrier (mult_of R)"
    using G.nat_pow_closed[OF a] by auto
  with _ have "carrier (mult_of R) = {a[^]i|i::nat. i  UNIV}"
    by (rule card_seteq[symmetric]) (simp_all add: card_R_minus_1 finite Coset.order_def del: UNIV_I)
  thus ?thesis using a a_ord by blast
qed

(*This lemma is a generalization of the theorem add_power_poly_mod_ring 
  which appears in Belekamp_Type_Based.thy*)

lemma add_power_prime_poly_mod_ring[simp]:
fixes x :: "'a::{prime_card} mod_ring poly"
shows "(x + y) ^ CARD('a)^n = x ^ (CARD('a)^n) + y ^ CARD('a)^n"
proof (induct n arbitrary: x y)
  case 0
  then show ?case by auto
next
  case (Suc n)
  define p where p: "p = CARD('a)"
  have "(x + y) ^ p ^ Suc n =  (x + y) ^ (p * p^n)" by simp
  also have "... = ((x + y) ^ p) ^ (p^n)"
    by (simp add: power_mult)
  also have "... = (x^p + y^p)^ (p^n)" 
    by (simp add: add_power_poly_mod_ring p)
  also have "... = (x^p)^(p^n) + (y^p)^(p^n)" using Suc.hyps unfolding p by auto
  also have "... = x^(p^(n+1)) + y^(p^(n+1))" by (simp add: power_mult)
  finally show ?case by (simp add: p)  
qed

(*This lemma is a generalization of the theorem fermat_theorem_mod_ring 
  which appears in Berlekamp_Type_Based.thy*)
lemma fermat_theorem_mod_ring2[simp]:
fixes a::"'a::{prime_card} mod_ring"
shows "a ^ (CARD('a)^n) = a"
proof (induct n arbitrary: a)
  case (Suc n)
  define p where "p = CARD('a)"
  have "a ^ p ^ Suc n = a ^ (p * (p ^ n))" by simp
  also have "... = (a ^ p) ^(p ^ n)" by (simp add: power_mult)
  also have "... = a^(p ^ n)" using fermat_theorem_mod_ring[of "a^p"] unfolding p_def by auto
  also have "... = a" using Suc.hyps p_def by auto
  finally show ?case by (simp add: p_def)
qed auto

lemma fermat_theorem_power_poly[simp]:
  fixes a::"'a::prime_card mod_ring"
  shows "[:a:] ^ CARD('a::prime_card) ^ n = [:a:]" 
  by (auto simp add: Missing_Polynomial.poly_const_pow mod_poly_less)

(* Some previous facts *)
lemma degree_prod_monom: "degree (i = 0..<n. monom 1 1) = n"
  by (metis degree_monom_eq prod_pow x_pow_n zero_neq_one)

lemma degree_monom0[simp]: "degree (monom a 0) = 0" using degree_monom_le by auto
lemma degree_monom0'[simp]: "degree (monom 0 b) = 0" by auto

lemma sum_monom_mod:
  assumes "b < degree f"
  shows "(ib. monom (g i) i) mod f = (ib. monom (g i) i)"
  using assms 
proof (induct b)
  case 0
  then show ?case by (auto simp add: mod_poly_less)
next
  case (Suc b)
  have hyp: "(ib. monom (g i) i) mod f = (ib. monom (g i) i)" 
    using Suc.prems Suc.hyps by simp
  have rw_monom: "monom (g (Suc b)) (Suc b) mod f = monom (g (Suc b)) (Suc b)"
    by (metis Suc.prems degree_monom_eq mod_0 mod_poly_less monom_hom.hom_0_iff)
  have rw: "(iSuc b. monom (g i) i) = (monom (g (Suc b)) (Suc b) + (ib. monom (g i) i))"
    by auto  
  have "(iSuc b. monom (g i) i) mod f 
    = (monom (g (Suc b)) (Suc b) + (ib. monom (g i) i)) mod f" using rw by presburger
  also have "... =((monom (g (Suc b)) (Suc b)) mod f) + ((ib. monom (g i) i) mod f)" 
    using poly_mod_add_left by auto
  also have "... = monom (g (Suc b)) (Suc b) + (ib. monom (g i) i)" 
    using hyp rw_monom by presburger
  also have "... = (iSuc b. monom (g i) i)" using rw by auto
  finally show ?case .
qed

lemma x_power_aq_minus_1_rw:
  fixes x::nat
  assumes x: "x > 1" 
    and a: "a > 0" 
    and b: "b > 0"
  shows "x ^ (a * q) - 1 = ((x^a) - 1) * sum ((^) (x^a)) {..<q}"
proof -     
  have xa: "(x ^ a) > 0" using x by auto
  have int_rw1: "int (x ^ a) - 1 = int ((x ^ a) - 1)"
    using xa by linarith
  have int_rw2: "sum ((^) (int (x ^ a))) {..<q} = int (sum ((^) ((x ^ a))) {..<q})" 
    unfolding int_sum by simp
  have "int (x ^ a) ^ q = int (Suc ((x ^ a) ^ q - 1))" using xa by auto
  hence "int ((x ^ a) ^ q - 1) = int (x ^ a) ^ q - 1" using xa by presburger    
  also have "... = (int (x ^ a) - 1) * sum ((^) (int (x ^ a))) {..<q}" 
    by (rule power_diff_1_eq)
  also have "... = (int ((x ^ a) - 1)) * int (sum ((^) ( (x ^ a))) {..<q})" 
    unfolding int_rw1 int_rw2 by simp
  also have "... = int (((x ^ a) - 1) * (sum ((^) ( (x ^ a))) {..<q}))" by auto
  finally have aux: "int ((x ^ a) ^ q - 1) = int (((x ^ a) - 1) * sum ((^) (x ^ a)) {..<q})" .     
  have "x ^ (a * q) - 1 = (x^a)^q - 1"
    by (simp add: power_mult)
  also have "... = ((x^a) - 1) * sum ((^) (x^a)) {..<q}" 
    using aux unfolding int_int_eq .
  finally show ?thesis .
qed 

lemma dvd_power_minus_1_conv1:
  fixes x::nat
  assumes x: "x > 1" 
    and a: "a > 0" 
    and xa_dvd: "x ^ a - 1 dvd x^b - 1" 
    and b0: "b > 0"
  shows "a dvd b"
proof -
  define r where r[simp]: "r = b mod a"
  define q where q[simp]: "q = b div a"  
  have b: "b = a * q + r" by auto
  have ra: "r < a" by (simp add: a)
  hence xr_less_xa: "x ^ r - 1 < x ^ a - 1"
    using x power_strict_increasing_iff diff_less_mono x by simp
  have dvd: "x ^ a - 1 dvd x ^ (a * q) - 1"
    using x_power_aq_minus_1_rw[OF x a b0] unfolding dvd_def by auto
  have "x^b - 1 = x^b - x^r + x^r - 1"
    using assms(1) assms(4) by auto  
  also have "... = x^r * (x^(a*q) - 1) + x^r - 1"
    by (metis (no_types, lifting) b diff_mult_distrib2 mult.commute nat_mult_1_right power_add)
  finally have "x^b - 1 = x^r * (x^(a*q) - 1) + x^r - 1" .
  hence "x ^ a - 1 dvd x ^ r * (x ^ (a * q) - 1) + x ^ r - 1" using xa_dvd by presburger
  hence "x^a - 1 dvd x^r - 1" 
    by (metis (no_types) diff_add_inverse diff_commute dvd dvd_diff_nat dvd_trans dvd_triv_right)  
  hence "r = 0" 
    using xr_less_xa
    by (meson nat_dvd_not_less neq0_conv one_less_power x zero_less_diff)
  thus ?thesis by auto
qed


lemma dvd_power_minus_1_conv2:
  fixes x::nat
  assumes x: "x > 1" 
    and a: "a > 0" 
    and a_dvd_b: "a dvd b" 
    and b0: "b > 0"
  shows "x ^ a - 1 dvd x^b - 1"
proof -
  define q where q[simp]: "q = b div a"  
  have b: "b = a * q" using a_dvd_b by auto
  have "x^b - 1 = ((x ^ a) - 1) * sum ((^) (x ^ a)) {..<q}" 
    unfolding b by (rule x_power_aq_minus_1_rw[OF x a b0])
  thus ?thesis unfolding dvd_def by auto
qed

corollary dvd_power_minus_1_conv:
  fixes x::nat
  assumes x: "x > 1" 
    and a: "a > 0" 
    and b0: "b > 0"
  shows "a dvd b = (x ^ a - 1 dvd x^b - 1)"
  using assms dvd_power_minus_1_conv1 dvd_power_minus_1_conv2 by blast



(* Proof of part a) of exercise 16: given f(x) an irreducible polynomial modulo a prime p 
  of degree n, the p^n polynomials of degree less than n form a field under arithmetic 
  modulo f(x) and p.
*)


locale poly_mod_type_irr = poly_mod_type m "TYPE('a::prime_card)" for m + 
  fixes f::"'a::{prime_card} mod_ring poly"
  assumes irr_f: "irreducibled f"
begin

definition plus_irr :: "'a mod_ring poly 'a mod_ring poly  'a mod_ring poly"
  where "plus_irr a b = (a + b) mod f"

definition minus_irr :: "'a mod_ring poly 'a mod_ring poly  'a mod_ring poly"
  where "minus_irr x y  (x - y) mod f"

definition uminus_irr :: "'a mod_ring poly 'a mod_ring poly "
  where "uminus_irr x = -x"

definition mult_irr :: "'a mod_ring poly 'a mod_ring poly  'a mod_ring poly"
  where "mult_irr x y = ((x*y) mod f)"

definition carrier_irr :: "'a mod_ring poly set"
  where "carrier_irr = {x. degree x < degree f}"

definition power_irr :: "'a mod_ring poly  nat  'a mod_ring poly"
  where "power_irr p n = ((p^n) mod f)"

definition "R = carrier = carrier_irr, monoid.mult = mult_irr, one = 1, zero = 0, add = plus_irr"

lemma degree_f[simp]: "degree f > 0"
  using irr_f irreducibledD(1) by blast

lemma element_in_carrier: "(a  carrier R) = (degree a < degree f)" 
  unfolding R_def carrier_irr_def by auto

lemma f_dvd_ab:
  "a = 0  b = 0" if "f dvd a * b" 
    and a: "degree a < degree f" 
    and b: "degree b < degree f" 
proof (rule ccontr)
  assume "¬ (a = 0  b = 0)"
  then have "a  0" and "b  0"
    by simp_all
  with a b have "¬ f dvd a" and "¬ f dvd b"
    by (auto simp add: mod_poly_less dvd_eq_mod_eq_0)
  moreover from f dvd a * b irr_f have "f dvd a  f dvd b"
    by auto
  ultimately show False
    by simp
qed

lemma ab_mod_f0:
  "a = 0  b = 0" if "a * b mod f = 0" 
    and a: "degree a < degree f" 
    and b: "degree b < degree f" 
  using that f_dvd_ab by auto

lemma irreducibledD2:
  fixes p q :: "'b::{comm_semiring_1,semiring_no_zero_divisors} poly"
  assumes "irreducibled p"
  and  "degree q < degree p" and "degree q  0"
  shows "¬ q dvd p"
  using assms irreducibled_dvd_smult by force


lemma times_mod_f_1_imp_0:
  assumes x: "degree x < degree f" 
    and x2: "xa. x * xa mod f = 1  ¬ degree xa < degree f"    
  shows "x = 0" 
proof (rule ccontr)
  assume x3: "x  0"
  let ?u = "fst (bezout_coefficients f x)"
  let ?v = "snd (bezout_coefficients f x)"
  have "?u * f + ?v * x = gcd f x" using bezout_coefficients_fst_snd by auto
  also have "... = 1"
  proof (rule ccontr)
    assume g: "gcd f x  1"
    have "degree (gcd f x) < degree f"
        by (metis degree_0 dvd_eq_mod_eq_0 gcd_dvd1 gcd_dvd2 irr_f 
            irreducibledD(1) mod_poly_less nat_neq_iff x x3)
    have "¬ gcd f x dvd f"
    proof (rule irreducibledD2[OF irr_f])
      show "degree (gcd f x) < degree f"
        by (metis degree_0 dvd_eq_mod_eq_0 gcd_dvd1 gcd_dvd2 irr_f 
            irreducibledD(1) mod_poly_less nat_neq_iff x x3)
      show "degree (gcd f x)  0"
        by (metis (no_types, hide_lams) g degree_mod_less' gcd.bottom_left_bottom gcd_eq_0_iff 
            gcd_left_idem gcd_mod_left gr_implies_not0 x)
    qed
    moreover have "gcd f x dvd f" by auto
    ultimately show False by contradiction
  qed
  finally have "?v*x mod f = 1"
    by (metis degree_1 degree_f mod_mult_self3 mod_poly_less)
  hence "(x*(?v mod f)) mod f = 1" 
    by (simp add: mod_mult_right_eq mult.commute)
  moreover have "degree (?v mod f) < degree f"
    by (metis degree_0 degree_f degree_mod_less' not_gr_zero)
  ultimately show False using x2 by auto
qed

sublocale field_R: field R 
proof -
  have *: "y. degree y < degree f  f dvd x + y" if "degree x < degree f"
    for x :: "'a mod_ring poly"  
  proof -
    from that have "degree (- x) < degree f"
      by simp
    moreover have "f dvd (x + - x)"
      by simp
    ultimately show ?thesis
      by blast
  qed
  have **: "degree (x * y mod f) < degree f"
    if "degree x < degree f" and "degree y < degree f"
    for x y :: "'a mod_ring poly"
    using that by (cases "x = 0  y = 0")
      (auto intro: degree_mod_less' dest: f_dvd_ab)
  show "field R"
    by standard (auto simp add: R_def carrier_irr_def plus_irr_def mult_irr_def Units_def algebra_simps degree_add_less mod_poly_less mod_add_eq mult_poly_add_left mod_mult_left_eq mod_mult_right_eq mod_eq_0_iff_dvd ab_mod_f0 * ** dest: times_mod_f_1_imp_0)
qed

lemma zero_in_carrier[simp]: "0  carrier_irr" unfolding carrier_irr_def by auto

lemma card_carrier_irr[simp]: "card carrier_irr = CARD('a)^(degree f)"
proof -
  let ?A = "(carrier_vec (degree f):: 'a mod_ring vec set)"
  have bij_A_carrier: "bij_betw (Poly  list_of_vec) ?A carrier_irr" 
  proof (unfold bij_betw_def, rule conjI)
    show "inj_on (Poly  list_of_vec) ?A" by (rule inj_Poly_list_of_vec)
    show "(Poly  list_of_vec) ` ?A = carrier_irr" 
    proof (unfold image_def o_def carrier_irr_def, auto)
      fix xa assume "xa  ?A" thus "degree (Poly (list_of_vec xa)) < degree f"
        using degree_Poly_list_of_vec irr_f by blast
    next
      fix x::"'a mod_ring poly" 
      assume deg_x: "degree x < degree f"
      let ?xa = "vec_of_list (coeffs x @ replicate (degree f - length (coeffs x)) 0)"
      show "xacarrier_vec (degree f). x = Poly (list_of_vec xa)"
        by (rule bexI[of _ "?xa"], unfold carrier_vec_def, insert deg_x) 
           (auto simp add: degree_eq_length_coeffs)        
    qed
  qed 
  have "CARD('a)^(degree f) = card ?A" 
    by (simp add: card_carrier_vec)
  also have "... = card carrier_irr" using bij_A_carrier bij_betw_same_card by blast
  finally show ?thesis ..
qed

lemma finite_carrier_irr[simp]: "finite (carrier_irr)"
proof -
  have "degree f > degree 0" using degree_0 by auto
  hence "carrier_irr  {}" using degree_0 unfolding carrier_irr_def
    by blast
  moreover have "card carrier_irr  0" by auto
  ultimately show ?thesis using card_eq_0_iff by metis  
qed  

lemma finite_carrier_R[simp]: "finite (carrier R)" unfolding R_def by simp

lemma finite_carrier_mult_of[simp]: "finite (carrier (mult_of R))" 
  unfolding carrier_mult_of by auto

lemma constant_in_carrier[simp]: "[:a:]  carrier R"
  unfolding R_def carrier_irr_def by auto

lemma mod_in_carrier[simp]: "a mod f  carrier R" 
  unfolding R_def carrier_irr_def
  by (auto, metis degree_0 degree_f degree_mod_less' less_not_refl)

lemma order_irr: "Coset.order (mult_of R) = CARD('a)^degree f - 1"
  by (simp add: card_Diff_singleton Coset.order_def carrier_mult_of R_def)
 
lemma element_power_order_eq_1:
    assumes x: "x  carrier (mult_of R)" 
    shows "x [^](mult_of R) Coset.order (mult_of R) = 𝟭(mult_of R)"
  by (meson field_R.field_mult_group finite_carrier_mult_of group.pow_order_eq_1 x)

corollary element_power_order_eq_1': 
assumes x: "x  carrier (mult_of R)"
shows"x [^](mult_of R) CARD('a)^degree f = x"
proof -  
  have "x [^](mult_of R) CARD('a)^degree f 
  = x (mult_of R) x [^](mult_of R) (CARD('a)^degree f - 1)" 
    by (metis Diff_iff One_nat_def Suc_pred field_R.m_comm field_R.nat_pow_Suc field_R.nat_pow_closed 
        mult_of_simps(1) mult_of_simps(2) nat_pow_mult_of neq0_conv power_eq_0_iff x zero_less_card_finite)  
  also have "x (mult_of R) x [^](mult_of R) (CARD('a)^degree f - 1) = x"     
    by (metis carrier_mult_of element_power_order_eq_1 field_R.Units_closed field_R.field_Units 
        field_R.r_one monoid.simps(2) mult_mult_of mult_of_def order_irr x)
  finally show ?thesis .  
qed  

lemma pow_irr[simp]: "x [^](R) n= x^n mod f"
  by (induct n, auto simp add: mod_poly_less nat_pow_def R_def mult_of_def mult_irr_def 
      carrier_irr_def mod_mult_right_eq mult.commute)

lemma pow_irr_mult_of[simp]: "x [^](mult_of R) n= x^n mod f"
  by (induct n, auto simp add: mod_poly_less nat_pow_def R_def mult_of_def mult_irr_def 
      carrier_irr_def mod_mult_right_eq mult.commute)

lemma fermat_theorem_power_poly_R[simp]: "[:a:] [^]R CARD('a) ^ n = [:a:]"
  by (auto simp add: Missing_Polynomial.poly_const_pow mod_poly_less)

lemma times_mod_expand:
  "(a (R) b) = ((a mod f) (R) (b mod f))"
  by (simp add: mod_mult_eq R_def mult_irr_def)

(*Elements that satisfy y^p^m = y in the field are closed under addition and multiplication.*)
lemma mult_closed_power:
assumes x: "x  carrier R" and y: "y  carrier R"
and "x [^](R) CARD('a) ^ m' = x"
and "y [^](R) CARD('a) ^ m' = y"
shows "(x (R) y) [^](R) CARD('a) ^ m' = (x (R) y)" 
  using assms assms field_R.nat_pow_distrib by auto

lemma add_closed_power:
assumes x1: "x [^](R) CARD('a) ^ m' = x"
and y1: "y [^](R) CARD('a) ^ m' = y"
shows "(x (R) y) [^](R) CARD('a) ^ m' = (x (R) y)"
proof -
  have "(x + y) ^ CARD('a) ^ m' = x^(CARD('a) ^ m') + y ^ (CARD('a) ^ m')" by auto  
  hence "(x + y) ^ CARD('a) ^ m' mod f = (x^(CARD('a) ^ m') + y ^ (CARD('a) ^ m')) mod f" by auto
  hence "(x (R) y) [^](R) CARD('a) ^ m' 
  = (x [^](R) CARD('a)^m') (R) (y [^](R) CARD('a)^m')"    
    by (auto, unfold R_def plus_irr_def, auto simp add: mod_add_eq power_mod)
  also have "... = x (R) y" unfolding x1 y1 by simp
  finally show ?thesis .
qed

lemma x_power_pm_minus_1: 
  assumes x: "x  carrier (mult_of R)"
  and "x [^](R) CARD('a) ^ m' = x"
  shows "x [^](R) (CARD('a) ^ m' - 1) = 𝟭(R)"
  by (metis (no_types, lifting) One_nat_def Suc_pred assms(2) carrier_mult_of field_R.Units_closed 
      field_R.Units_l_cancel field_R.field_Units field_R.l_one field_R.m_rcancel field_R.nat_pow_Suc 
      field_R.nat_pow_closed field_R.one_closed field_R.r_null field_R.r_one x zero_less_card_finite 
      zero_less_power)

context
begin

private lemma monom_a_1_P:
  assumes m: "monom 1 1  carrier R"
  and eq: "monom 1 1 [^](R) (CARD('a) ^ m') = monom 1 1"
  shows "monom a 1 [^](R) (CARD('a) ^ m') = monom a 1"
proof -
  have "monom a 1 = [:a:] * (monom 1 1)"
    by (metis One_nat_def monom_0 monom_Suc mult.commute pCons_0_as_mult)
  also have "... = [:a:] (R) (monom 1 1)" 
    by (auto simp add: R_def mult_irr_def)
       (metis One_nat_def assms(2) mod_mod_trivial mod_smult_left pow_irr)
  finally have eq2: "monom a 1 = [:a:] R monom 1 1" .
  show ?thesis unfolding eq2 
    by (rule mult_closed_power[OF _ m _ eq], insert fermat_theorem_power_poly_R, auto)
qed

private lemma prod_monom_1_1:
  defines "P == (λ x n. (x[^](R) (CARD('a) ^ n) = x))"
  assumes m: "monom 1 1  carrier R"
  and eq: "P (monom 1 1) n"
  shows "P ((i = 0..<b::nat. monom 1 1) mod f) n"
proof (induct b)
  case 0
  then show ?case unfolding P_def
    by (simp add: power_mod)
next
  case (Suc b)
  let ?N = "(i = 0..<b. monom 1 1)"
  have eq2: "(i = 0..<Suc b. monom 1 1) mod f = monom 1 1 (R) (i = 0..<b. monom 1 1)"
    by (metis field_R.m_comm field_R.nat_pow_Suc mod_in_carrier mod_mod_trivial 
        pow_irr prod_pow times_mod_expand)
  also have "... = (monom 1 1 mod f) (R) ((i = 0..<b. monom 1 1) mod f)" 
    by (rule times_mod_expand)
  finally have eq2: "(i = 0..<Suc b. monom 1 1) mod f 
    = (monom 1 1 mod f) (R) ((i = 0..<b. monom 1 1) mod f)" .
  show ?case 
  unfolding eq2 P_def 
  proof (rule mult_closed_power)
    show "(monom 1 1 mod f) [^]R CARD('a) ^ n = monom 1 1 mod f"
      using P_def element_in_carrier eq m mod_poly_less by force
    show "((i = 0..<b. monom 1 1) mod f) [^]R CARD('a) ^ n = (i = 0..<b. monom 1 1) mod f"      
      using P_def Suc.hyps by blast
  qed (auto)
qed


private lemma monom_1_b:
  defines "P == (λ x n. (x[^](R) (CARD('a) ^ n) = x))"
  assumes m: "monom 1 1  carrier R"
  and monom_1_1: "P (monom 1 1) m'"
  and b: "b < degree f"
  shows "P (monom 1 b) m'"
proof -
  have "monom 1 b = (i = 0..<b. monom 1 1)"
    by (metis prod_pow x_pow_n)
  also have "... = (i = 0..<b. monom 1 1) mod f" 
    by (rule mod_poly_less[symmetric], auto)
       (metis One_nat_def b degree_linear_power x_as_monom)
  finally have eq2: "monom 1 b = (i = 0..<b. monom 1 1) mod f" .
  show ?thesis unfolding eq2 P_def 
    by (rule prod_monom_1_1[OF m monom_1_1[unfolded P_def]])  
qed



private lemma monom_a_b:
  defines "P == (λ x n. (x[^](R) (CARD('a) ^ n) = x))"
  assumes m: "monom 1 1  carrier R"
  and m1: "P (monom 1 1) m'"
  and b: "b < degree f"
  shows "P (monom a b) m'"
proof -
  have "monom a b = smult a (monom 1 b)"
    by (simp add: smult_monom)
  also have "... = [:a:] * (monom 1 b)" by auto
  also have "... = [:a:] (R) (monom 1 b)" 
    unfolding R_def mult_irr_def
    by (simp add: b degree_monom_eq mod_poly_less)
  finally have eq: "monom a b = [:a:] (R) (monom 1 b)" .
  show ?thesis unfolding eq P_def 
  proof (rule mult_closed_power)
    show "[:a:] [^]R CARD('a) ^ m' = [:a:]" by (rule fermat_theorem_power_poly_R)
    show "monom 1 b [^]R CARD('a) ^ m' = monom 1 b" 
      unfolding P_def by (rule monom_1_b[OF m m1[unfolded P_def] b])
    show "monom 1 b  carrier R" unfolding element_in_carrier using b
      by (simp add: degree_monom_eq)
  qed (auto)
qed


private lemma sum_monoms_P:
  defines "P == (λ x n. (x[^](R) (CARD('a) ^ n) = x))"
  assumes m: "monom 1 1  carrier R"
  and monom_1_1: "P (monom 1 1) n"
  and b: "b < degree f"
shows "P ((ib. monom (g i) i)) n"
  using b
proof (induct b)
  case 0
  then show ?case unfolding P_def
    by (simp add: poly_const_pow mod_poly_less monom_0)
next
  case (Suc b)
  have b: "b < degree f" using Suc.prems by auto
  have rw: "(ib. monom (g i) i) mod f = (ib. monom (g i) i)" by (rule sum_monom_mod[OF b])
  have rw2: "(monom (g (Suc b)) (Suc b) mod f) = monom (g (Suc b)) (Suc b)"
    by (metis Suc.prems field_R.nat_pow_eone m monom_a_b pow_irr power_0 power_one_right)
  have hyp: "P (ib. monom (g i) i) n" using Suc.prems Suc.hyps by auto
  have "(iSuc b. monom (g i) i) = monom (g (Suc b)) (Suc b) + (ib. monom (g i) i)"    
    by simp
  also have "... = (monom (g (Suc b)) (Suc b) mod f) + ((ib. monom (g i) i) mod f)" 
    using rw rw2 by argo
  also have "... = monom (g (Suc b)) (Suc b) R (ib. monom (g i) i)" 
    unfolding R_def plus_irr_def
    by (simp add: poly_mod_add_left)
  finally have eq: "(iSuc b. monom (g i) i) 
    = monom (g (Suc b)) (Suc b) R (ib. monom (g i) i)" .  
  show ?case unfolding eq P_def 
  proof (rule add_closed_power)
    show "monom (g (Suc b)) (Suc b) [^]R CARD('a) ^ n = monom (g (Suc b)) (Suc b)"
      by (rule monom_a_b[OF m monom_1_1[unfolded P_def] Suc.prems])
    show "(ib. monom (g i) i) [^]R CARD('a) ^ n = (ib. monom (g i) i)" 
      using hyp unfolding P_def by simp
  qed
qed

lemma element_carrier_P:
  defines "P  (λ x n. (x[^](R) (CARD('a) ^ n) = x))"
  assumes m: "monom 1 1  carrier R"
  and monom_1_1: "P (monom 1 1) m'"
  and a: "a  carrier R"
shows "P a m'"
proof -
  have degree_a: "degree a < degree f" using a element_in_carrier by simp
  have "P (idegree a. monom (poly.coeff a i) i) m'"
    unfolding P_def
    by (rule sum_monoms_P[OF m monom_1_1[unfolded P_def] degree_a])
  thus ?thesis unfolding poly_as_sum_of_monoms by simp
qed
end

end

(* First part of the result that we need *)
lemma degree_divisor1: 
  assumes f: "irreducible (f :: 'a :: prime_card mod_ring poly)" 
  and d: "degree f = d" 
shows "f dvd (monom 1 1)^(CARD('a)^d) - monom 1 1"
proof -
  interpret poly_mod_type_irr "CARD('a)" f by (unfold_locales, auto simp add: f)
  show ?thesis
  proof (cases "d = 1")
    case True
    show ?thesis
    proof (cases "monom 1 1 mod f = 0")
      case True
      then show ?thesis
        by (metis Suc_pred dvd_diff dvd_mult2 mod_eq_0_iff_dvd power.simps(2) 
            zero_less_card_finite zero_less_power)
    next
      case False note mod_f_not0 = False    
      have "monom 1 (CARD('a)) mod f = monom 1 1 mod f"
      proof -
        let ?g1 = "(monom 1 (CARD('a))) mod f"
        let ?g2 = "(monom 1 1) mod f"
        have deg_g1: "degree ?g1 < degree f" and deg_g2: "degree ?g2 < degree f"
          by (metis True card_UNIV_unit d degree_0 degree_mod_less' zero_less_card_finite zero_neq_one)+   
        have g2: "?g2 [^](mult_of R) CARD('a)^degree f = ?g2 ^ (CARD('a)^degree f) mod f"
          by (rule pow_irr_mult_of)
        have "?g2 [^](mult_of R) CARD('a)^degree f = ?g2" 
          by (rule element_power_order_eq_1', insert mod_f_not0 deg_g2, 
              auto simp add: carrier_mult_of R_def carrier_irr_def )  
        hence "?g2 ^ CARD('a) mod f = ?g2 mod f" using True d by auto    
        hence "?g1 mod f = ?g2 mod f" by (metis mod_mod_trivial power_mod x_pow_n)
        thus ?thesis by simp
      qed
      thus ?thesis by (metis True mod_eq_dvd_iff_poly power_one_right x_pow_n) 
    qed
  next
    case False
    have deg_f1: "1 < degree f"
      using False d degree_f by linarith
    have "monom 1 1 [^](mult_of R) CARD('a)^degree f = monom 1 1"
      by (rule element_power_order_eq_1', insert deg_f1) 
          (auto simp add: carrier_mult_of R_def carrier_irr_def degree_monom_eq) 
    hence "monom 1 1^CARD('a)^degree f mod f = monom 1 1 mod f" 
      using deg_f1 by (auto, metis mod_mod_trivial)
    thus ?thesis using d mod_eq_dvd_iff_poly by blast
  qed
qed

(* Second part *)
lemma degree_divisor2: 
  assumes f: "irreducible (f :: 'a :: prime_card mod_ring poly)" 
  and d: "degree f = d" 
  and c_ge_1: "1  c" and cd: "c < d"
shows "¬ f dvd monom 1 1 ^ CARD('a) ^ c - monom 1 1"
proof (rule ccontr)
  interpret poly_mod_type_irr "CARD('a)" f by (unfold_locales, auto simp add: f)
  have field_R: "field R"
    by (simp add: field_R.field_axioms)
  assume "¬ ¬ f dvd monom 1 1 ^ CARD('a) ^ c - monom 1 1"
  hence f_dvd: "f dvd monom 1 1 ^ CARD('a) ^ c - monom 1 1" by simp 
  obtain a where a_R: "a  carrier (mult_of R)" 
    and ord_a: "group.ord (mult_of R) a = order (mult_of R)" 
    and gen: "carrier (mult_of R) = {a [^]R i |i. i  (UNIV::nat set)}" 
    using field.finite_field_mult_group_has_gen2[OF field_R] by auto
  have d_not1: "d>1" using c_ge_1 cd by auto
  have monom_in_carrier: "monom 1 1  carrier (mult_of R)" 
    using d_not1 unfolding carrier_mult_of R_def carrier_irr_def
    by (simp add: d degree_monom_eq)
  then have "monom 1 1  {𝟬R}"
    by auto
  then obtain k where "monom 1 1 = a ^ k mod f"
    using gen monom_in_carrier by auto
  then have k: "a [^]R k = monom 1 1"
    by simp
  have a_m_1: "a [^]R (CARD('a)^c - 1) = 𝟭R"
  proof (rule x_power_pm_minus_1[OF a_R])
    let ?x = "monom 1 1::'a mod_ring poly"
    show "a [^]R CARD('a) ^ c = a" 
    proof (rule element_carrier_P)
      show "?x  carrier R"
        by (metis k mod_in_carrier pow_irr)
      have "?x ^ CARD('a)^ c mod f = ?x mod f" using f_dvd
        using mod_eq_dvd_iff_poly by blast
      thus "?x [^]R CARD('a)^ c = ?x"
        by (metis d d_not1 degree_monom_eq mod_poly_less one_neq_zero pow_irr)
      show "a  carrier R" using a_R unfolding carrier_mult_of by auto
    qed  
  qed
  have "Group.group (mult_of R)"
    by (simp add: field_R.field_mult_group)
  moreover have "finite (carrier (mult_of R))" by auto
  moreover have "a  carrier (mult_of R)" by (rule a_R )
  moreover have "a [^]mult_of R (CARD('a) ^ c - 1) = 𝟭mult_of R" 
    using a_m_1 unfolding mult_of_def 
    by (auto, metis mult_of_def pow_irr_mult_of nat_pow_mult_of)
  ultimately have ord_dvd: "group.ord (mult_of R) a dvd (CARD('a)^c - 1)" 
    by (meson group.pow_eq_id)
  have "d dvd c" 
  proof (rule dvd_power_minus_1_conv1[OF nontriv])    
    show "0 < d" using cd by auto
    show "CARD('a) ^ d - 1 dvd CARD('a) ^ c - 1" 
      using ord_dvd by (simp add: d ord_a order_irr)
    show "0 < c" using c_ge_1 by auto
  qed
  thus False using c_ge_1 cd
    using nat_dvd_not_less by auto
qed

lemma degree_divisor: assumes "irreducible (f :: 'a :: prime_card mod_ring poly)" "degree f = d" 
  shows "f dvd (monom 1 1)^(CARD('a)^d) - monom 1 1" 
  and "1  c  c < d  ¬ f dvd (monom 1 1)^(CARD('a)^c) - monom 1 1"
    using assms degree_divisor1 degree_divisor2 by blast+

context 
  assumes "SORT_CONSTRAINT('a :: prime_card)" 
begin

function dist_degree_factorize_main :: 
  "'a mod_ring poly  'a mod_ring poly  nat  (nat × 'a mod_ring poly) list 
   (nat × 'a mod_ring poly) list" where
  "dist_degree_factorize_main v w d res = (if v = 1 then res else if d + d > degree v 
    then (degree v, v) # res else let
      w = w^(CARD('a)) mod v;
      d = Suc d;
      gd = gcd (w - monom 1 1) v
      in if gd = 1 then dist_degree_factorize_main v w d res else 
      let v' = v div gd in 
      dist_degree_factorize_main v' (w mod v') d ((d,gd) # res))" 
  by pat_completeness auto


termination 
proof (relation "measure (λ (v,w,d,res). Suc (degree v) - d)", goal_cases) 
  case (3 v w d res x xa xb xc) 
  have "xb dvd v" unfolding 3 by auto
  hence "xc dvd v" unfolding 3 by (metis dvd_def dvd_div_mult_self)
  from divides_degree[OF this] 3
  show ?case by auto
qed auto

declare dist_degree_factorize_main.simps[simp del]
  
lemma dist_degree_factorize_main: assumes 
  dist: "dist_degree_factorize_main v w d res = facts" and
  w: "w = (monom 1 1)^(CARD('a)^d) mod v" and
  sf: "square_free u" and  
  mon: "monic u" and
  prod: "u = v * prod_list (map snd res)" and
  deg: " f. irreducible f  f dvd v  degree f > d" and
  res: " i f. (i,f)  set res  i  0  degree f  0  monic f  ( g. irreducible g  g dvd f  degree g = i)" 
shows "u = prod_list (map snd facts)  ( i f. (i,f)  set facts  factors_of_same_degree i f)" 
  using dist w prod res deg unfolding factors_of_same_degree_def
proof (induct v w d res rule: dist_degree_factorize_main.induct)
  case (1 v w d res)
  note IH = 1(1-2)
  note result = 1(3)
  note w = 1(4)
  note u = 1(5)
  note res = 1(6)
  note fact = 1(7)
  note [simp] = dist_degree_factorize_main.simps[of _ _ d] 
  let ?x = "monom 1 1 :: 'a mod_ring poly" 
  show ?case
  proof (cases "v = 1") 
    case True
    thus ?thesis using result u mon res by auto
  next
    case False note v = this
    note IH = IH[OF this]
    have mon_prod: "monic (prod_list (map snd res))" by (rule monic_prod_list, insert res, auto)
    with mon[unfolded u] have mon_v: "monic v" by (simp add: coeff_degree_mult)
    with False have deg_v: "degree v  0" by (simp add: monic_degree_0)
    show ?thesis
    proof (cases "degree v < d + d")
      case True
      with result False have facts: "facts = (degree v, v) # res" by simp
      show ?thesis 
      proof (intro allI conjI impI)
        fix i f g
        assume *: "(i,f)  set facts" "irreducible g" "g dvd f"          
        show "degree g = i"
        proof (cases "(i,f)  set res")
          case True
          from res[OF this] * show ?thesis by auto
        next
          case False
          with * facts have id: "i = degree v" "f = v" by auto
          note * = *(2-3)[unfolded id]
          from fact[OF *] have dg: "d < degree g" by auto
          from divides_degree[OF *(2)] mon_v have deg_gv: "degree g  degree v" by auto
          from *(2) obtain h where vgh: "v = g * h" unfolding dvd_def by auto
          from arg_cong[OF this, of degree] mon_v have dvgh: "degree v = degree g + degree h" 
            by (metis deg_v degree_mult_eq degree_mult_eq_0) 
          with dg deg_gv dg True have deg_h: "degree h < d" by auto
          {
            assume "degree h = 0" 
            with dvgh have "degree g = degree v" by simp
          }
          moreover
          {
            assume deg_h0: "degree h  0" 
            hence " k. irreducibled k  k dvd h" 
              using dvd_triv_left irreducibled_factor by blast
            then obtain k where irr: "irreducible k" and "k dvd h" by auto
            from dvd_trans[OF this(2), of v] vgh have "k dvd v" by auto
            from fact[OF irr this] have dk: "d < degree k" .
            from divides_degree[OF k dvd h] deg_h0 have "degree k  degree h" by auto
            with deg_h have "degree k < d" by auto
            with dk have False by auto
          }
          ultimately have "degree g = degree v" by auto
          thus ?thesis unfolding id by auto
        qed
      qed (insert v mon_v deg_v u facts res, force+)        
    next
      case False
      note IH = IH[OF this refl refl refl]
      let ?p = "CARD('a)" 
      let ?w = "w ^ ?p mod v"
      let ?g = "gcd (?w - ?x) v" 
      let ?v = "v div ?g" 
      let ?d = "Suc d" 
      from result[simplified] v False
      have result: "(if ?g = 1 then dist_degree_factorize_main v ?w ?d res
                  else dist_degree_factorize_main ?v (?w mod ?v) ?d ((?d, ?g) # res)) = facts" 
        by (auto simp: Let_def)
      from mon_v have mon_g: "monic ?g" by (metis deg_v degree_0 poly_gcd_monic)
      have ww: "?w = ?x ^ ?p ^ ?d mod v" unfolding w
        by simp (metis (mono_tags, hide_lams) One_nat_def mult.commute power_Suc power_mod power_mult x_pow_n)
      have gv: "?g dvd v" by auto
      hence gv': "v div ?g dvd v"
        by (metis dvd_def dvd_div_mult_self)
      {
        fix f
        assume irr: "irreducible f" and fv: "f dvd v" and "degree f = ?d" 
        from degree_divisor(1)[OF this(1,3)]
        have "f dvd ?x ^ ?p ^ ?d - ?x" by auto
        hence "f dvd (?x ^ ?p ^ ?d - ?x) mod v" using fv by (rule dvd_mod)
        also have "(?x ^ ?p ^ ?d - ?x) mod v = ?x ^ ?p ^ ?d mod v - ?x mod v" by (rule poly_mod_diff_left)
        also have "?x ^ ?p ^ ?d mod v = ?w mod v" unfolding ww by auto
        also have " - ?x mod v = (w ^ ?p mod v - ?x) mod v" by (metis poly_mod_diff_left)
        finally have "f dvd (w^?p mod v - ?x)" using fv by (rule dvd_mod_imp_dvd)
        with fv have "f dvd ?g" by auto
      } note deg_d_dvd_g = this
      show ?thesis
      proof (cases "?g = 1")
        case True
        with result have dist: "dist_degree_factorize_main v ?w ?d res = facts" by auto
        show ?thesis 
        proof (rule IH(1)[OF True dist ww u res])
          fix f
          assume irr: "irreducible f" and fv: "f dvd v" 
          from fact[OF this] have "d < degree f" .
          moreover have "degree f  ?d"
          proof
            assume "degree f = ?d" 
            from divides_degree[OF deg_d_dvd_g[OF irr fv this]] mon_v
            have "degree f  degree ?g" by auto
            with irr have "degree ?g  0" unfolding irreducibled_def by auto
            with True show False by auto
          qed
          ultimately show "?d < degree f" by auto
        qed
      next
        case False
        with result 
        have result: "dist_degree_factorize_main ?v (?w mod ?v) ?d ((?d, ?g) # res) = facts" 
          by auto 
        from False mon_g have deg_g: "degree ?g  0" by (simp add: monic_degree_0)
        have www: "?w mod ?v = monom 1 1 ^ ?p ^ ?d mod ?v" using gv'
          by (simp add: mod_mod_cancel ww)
        from square_free_factor[OF _ sf, of v] u have sfv: "square_free v" by auto
        have u: "u = ?v * prod_list (map snd ((?d, ?g) # res))" 
          unfolding u by simp
        show ?thesis
        proof (rule IH(2)[OF False refl result www u], goal_cases)
          case (1 i f)
          show ?case
          proof (cases "(i,f)  set res")
            case True
            from res[OF this] show ?thesis by auto
          next
            case False
            with 1 have id: "i = ?d" "f = ?g" by auto
            show ?thesis unfolding id 
            proof (intro conjI impI allI)
              fix g
              assume *: "irreducible g" "g dvd ?g"
              hence gv: "g dvd v" using dvd_trans[of g ?g v] by simp
              from fact[OF *(1) this] have dg: "d < degree g" .
              {
                assume "degree g > ?d"
                from degree_divisor(2)[OF *(1) refl _ this]
                have ndvd: "¬ g dvd ?x ^ ?p ^ ?d - ?x" by auto 
                from *(2) have "g dvd ?w - ?x" by simp
                from this[unfolded ww]
                have "g dvd ?x ^ ?p ^ ?d mod v - ?x" .
                with gv have "g dvd (?x ^ ?p ^ ?d mod v - ?x) mod v" by (metis dvd_mod)
                also have "(?x ^ ?p ^ ?d mod v - ?x) mod v = (?x ^ ?p ^ ?d - ?x) mod v"
                  by (metis mod_diff_left_eq)
                finally have "g dvd ?x ^ ?p ^ ?d - ?x" using gv by (rule dvd_mod_imp_dvd)
                with ndvd have False by auto
              }
              with dg show "degree g = ?d" by presburger
            qed (insert mon_g deg_g, auto)
          qed
        next
          case (2 f)
          note irr = 2(1)
          from dvd_trans[OF 2(2) gv'] have fv: "f dvd v" .
          from fact[OF irr fv] have df: "d < degree f" "degree f  0" by auto
          {
            assume "degree f = ?d" 
            from deg_d_dvd_g[OF irr fv this] have fg: "f dvd ?g" .
            from gv have id: "v = (v div ?g) * ?g" by simp
            from sfv id have "square_free (v div ?g * ?g)" by simp
            from square_free_multD(1)[OF this 2(2) fg] have "degree f = 0" .
            with df have False by auto
          }
          with df show "?d < degree f" by presburger
        qed
      qed
    qed
  qed
qed

definition distinct_degree_factorization 
  :: "'a mod_ring poly  (nat × 'a mod_ring poly) list" where
  "distinct_degree_factorization f = 
     (if degree f = 1 then [(1,f)] else dist_degree_factorize_main f (monom 1 1) 0 [])"
  
lemma distinct_degree_factorization: assumes 
  dist: "distinct_degree_factorization f = facts" and
  u: "square_free f" and  
  mon: "monic f" 
shows "f = prod_list (map snd facts)  ( i f. (i,f)  set facts  factors_of_same_degree i f)" 
proof -
  note dist = dist[unfolded distinct_degree_factorization_def]
  show ?thesis 
  proof (cases "degree f  1")
    case False
    hence "degree f > 1" and dist: "dist_degree_factorize_main f (monom 1 1) 0 [] = facts" 
      using dist by auto
    hence *: "monom 1 (Suc 0) = monom 1 (Suc 0) mod f"
      by (simp add: degree_monom_eq mod_poly_less)
    show ?thesis
      by (rule dist_degree_factorize_main[OF dist _ u mon], insert *, auto simp: irreducibled_def)
  next
    case True
    hence "degree f = 0  degree f = 1" by auto
    thus ?thesis
    proof 
      assume "degree f = 0" 
      with mon have f: "f = 1" using monic_degree_0 by blast
      hence "facts = []" using dist unfolding dist_degree_factorize_main.simps[of _ _ 0]
        by auto
      thus ?thesis using f by auto
    next
      assume deg: "degree f = 1" 
      hence facts: "facts = [(1,f)]" using dist by auto
      show ?thesis unfolding facts factors_of_same_degree_def
      proof (intro conjI allI impI; clarsimp)
        fix g
        assume "irreducible g" "g dvd f" 
        thus "degree g = Suc 0" using deg divides_degree[of g f] by (auto simp: irreducibled_def)
      qed (insert mon deg, auto)
    qed
  qed
qed
end

end

Theory Finite_Field_Factorization

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹A Combined Factorization Algorithm for Polynomials over GF(p)›

subsection‹Type Based Version›
text ‹We combine Berlekamp's algorithm with the distinct degree factorization
  to obtain an efficient factorization algorithm for square-free polynomials in GF(p).›

theory Finite_Field_Factorization
imports Berlekamp_Type_Based
  Distinct_Degree_Factorization
begin

text ‹We prove soundness of the finite field factorization,
  indepedendent on whether distinct-degree-factorization is
  applied as preprocessing or not.›
consts use_distinct_degree_factorization :: bool

context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin

definition finite_field_factorization :: "'a mod_ring poly  'a mod_ring × 'a mod_ring poly list" where
  "finite_field_factorization f = (if degree f = 0 then (lead_coeff f,[]) else let
     a = lead_coeff f;
     u = smult (inverse a) f;
     gs = (if use_distinct_degree_factorization then distinct_degree_factorization u else [(1,u)]);
     (irr,hs) = List.partition (λ (i,f). degree f = i) gs
    in (a,map snd irr @ concat (map (λ (i,g). berlekamp_monic_factorization i g) hs)))"

lemma finite_field_factorization_explicit:
  fixes f::"'a mod_ring poly"
  assumes sf_f: "square_free f"
    and us: "finite_field_factorization f = (c,us)"
  shows "f = smult c (prod_list us)  ( u  set us. monic u  irreducible u)"
proof (cases "degree f = 0")
  case False note f = this
  define g where "g = smult (inverse c) f"    
  obtain gs where dist: "(if use_distinct_degree_factorization then distinct_degree_factorization g else [(1,g)]) = gs" by auto
  note us = us[unfolded finite_field_factorization_def Let_def]
  from us f have c: "c = lead_coeff f" by auto
  obtain irr hs where part: "List.partition (λ (i, f). degree f = i) gs = (irr,hs)" by force
  from arg_cong[OF this, of fst] have irr: "irr = filter (λ (i, f). degree f = i) gs" by auto
  from us[folded c, folded g_def, unfolded dist part split] f
  have us: "us = map snd irr @ concat (map (λ(x, y). berlekamp_monic_factorization x y) hs)" by auto
  from f c have c0: "c  0" by auto
  from False c0 have deg_g: "degree g  0" unfolding g_def by auto
  have mon_g: "monic g" unfolding g_def
    by (metis c c0 field_class.field_inverse lead_coeff_smult)
  from sf_f have sf_g: "square_free g" unfolding g_def by (simp add: c0)
  from c0 have f: "f = smult c g" unfolding g_def by auto
  have "g = prod_list (map snd gs)  ( (i,f)  set gs. degree f > 0  monic f  ( h. h dvd f  degree h = i  irreducible h))" 
  proof (cases use_distinct_degree_factorization)
    case True
    with dist have "distinct_degree_factorization g = gs" by auto
    note dist = distinct_degree_factorization[OF this sf_g mon_g]
    from dist have g: "g = prod_list (map snd gs)" by auto
    show ?thesis
    proof (intro conjI[OF g] ballI, clarify)
      fix i f
      assume "(i,f)  set gs" 
      with dist have "factors_of_same_degree i f" by auto
      from factors_of_same_degreeD[OF this] 
      show "degree f > 0  monic f  (h. h dvd f  degree h = i  irreducible h)" by auto
    qed
  next
    case False
    with dist have gs: "gs = [(1,g)]" by auto
    show ?thesis unfolding gs using deg_g mon_g linear_irreducibled[where 'a = "'a mod_ring"] by auto
  qed
  hence g_gs: "g = prod_list (map snd gs)" 
    and mon_gs: " i f. (i, f)  set gs  monic f  degree f > 0" 
    and irrI: " i f h . (i, f)  set gs  h dvd f  degree h = i  irreducible h" by auto
  have g: "g = prod_list (map snd irr) * prod_list (map snd hs)" unfolding g_gs
    using prod_list_map_partition[OF part] .
  {
    fix f
    assume "f  snd ` set irr" 
    from this[unfolded irr] obtain i where *:  "(i,f)  set gs" "degree f = i" by auto
    have "f dvd f" by auto
    from irrI[OF *(1) this *(2)] mon_gs[OF *(1)] have "monic f" "irreducible f" by auto
  } note irr = this
  let ?berl = "λ hs. concat (map (λ(x, y). berlekamp_monic_factorization x y) hs)"
  have "set hs  set gs" using part by auto
  hence "prod_list (map snd hs) = prod_list (?berl hs)
     ( f  set (?berl hs). monic f  irreducibled f)" 
  proof (induct hs)
    case (Cons ih hs)
    obtain i h where ih: "ih = (i,h)" by force
    have "?berl (Cons ih hs) = berlekamp_monic_factorization i h @ ?berl hs" unfolding ih by auto
    from Cons(2)[unfolded ih] have mem: "(i,h)  set gs" and sub: "set hs  set gs" by auto
    note IH = Cons(1)[OF sub]
    from mem have "h  set (map snd gs)" by force
    from square_free_factor[OF prod_list_dvd[OF this], folded g_gs, OF sf_g] have sf: "square_free h" .
    from mon_gs[OF mem] irrI[OF mem] have *: "degree h > 0" "monic h" 
      " g. g dvd h  degree g = i  irreducible g" by auto
    from berlekamp_monic_factorization[OF sf refl *(3) *(1-2), of i]
    have berl: "prod_list (berlekamp_monic_factorization i h) = h" 
      and irr: " f. f  set (berlekamp_monic_factorization i h)  monic f  irreducible f" by auto
    have "prod_list (map snd (Cons ih hs)) = h * prod_list (map snd hs)" unfolding ih by simp
    also have "prod_list (map snd hs) = prod_list (?berl hs)" using IH by auto
    finally have "prod_list (map snd (Cons ih hs)) = prod_list (?berl (Cons ih hs))" 
      unfolding ih using berl by auto
    thus ?case using IH irr unfolding ih by auto
  qed auto
  with g irr have main: "g = prod_list us  ( u  set us. monic u  irreducibled u)" unfolding us
    by auto
  thus ?thesis unfolding f using sf_g by auto
next
  case True
  with us[unfolded finite_field_factorization_def] have "c = lead_coeff f" and us: "us = []" by auto
  with degree0_coeffs[OF True] have f: "f = [:c:]" by auto
  show ?thesis unfolding us f by (auto simp: normalize_poly_def)
qed

lemma finite_field_factorization:
  fixes f::"'a mod_ring poly"
  assumes sf_f: "square_free f"
    and us: "finite_field_factorization f = (c,us)"
  shows "unique_factorization Irr_Mon f (c, mset us)"
proof -
  from finite_field_factorization_explicit[OF sf_f us]
  have fact: "factorization Irr_Mon f (c, mset us)"
    unfolding factorization_def split Irr_Mon_def by (auto simp: prod_mset_prod_list)
  from sf_f[unfolded square_free_def] have "f  0" by auto
  from exactly_one_factorization[OF this] fact
  show ?thesis unfolding unique_factorization_def by auto
qed
end

text ‹Experiments revealed that preprocessing via 
  distinct-degree-factorization slows down the factorization
  algorithm (statement for implementation in AFP 2017)›

overloading use_distinct_degree_factorization  use_distinct_degree_factorization
begin
  definition use_distinct_degree_factorization
    where [code_unfold]: "use_distinct_degree_factorization = False"
end
end

Theory Finite_Field_Factorization_Record_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Record Based Version›
theory Finite_Field_Factorization_Record_Based
imports
  Finite_Field_Factorization 
  Matrix_Record_Based
  Poly_Mod_Finite_Field_Record_Based
  "HOL-Types_To_Sets.Types_To_Sets"
  Jordan_Normal_Form.Matrix_IArray_Impl
  Jordan_Normal_Form.Gauss_Jordan_IArray_Impl  
  Polynomial_Interpolation.Improved_Code_Equations
  Polynomial_Factorization.Missing_List
begin

hide_const(open) monom coeff

text ‹Whereas @{thm finite_field_factorization} provides a result for a polynomials over GF(p),
  we now develop a theorem which speaks about integer polynomials modulo p.›
lemma (in poly_mod_prime_type) finite_field_factorization_modulo_ring:
  assumes g: "(g :: 'a mod_ring poly) = of_int_poly f"
  and sf: "square_free_m f"
  and fact: "finite_field_factorization g = (d,gs)"
  and c: "c = to_int_mod_ring d"
  and fs: "fs = map to_int_poly gs"
  shows "unique_factorization_m f (c, mset fs)"
proof -
  have [transfer_rule]: "MP_Rel f g" unfolding g MP_Rel_def by (simp add: Mp_f_representative)
  have sg: "square_free g" by (transfer, rule sf)
  have [transfer_rule]: "M_Rel c d" unfolding M_Rel_def c by (rule M_to_int_mod_ring)
  have fs_gs[transfer_rule]: "list_all2 MP_Rel fs gs"
    unfolding fs list_all2_map1 MP_Rel_def[abs_def] Mp_to_int_poly by (simp add: list.rel_refl)
  have [transfer_rule]: "rel_mset MP_Rel (mset fs) (mset gs)"
    using fs_gs using rel_mset_def by blast
  have [transfer_rule]: "MF_Rel (c,mset fs) (d,mset gs)" unfolding MF_Rel_def by transfer_prover
  from finite_field_factorization[OF sg fact]
  have uf: "unique_factorization Irr_Mon g (d,mset gs)" by auto
  from uf[untransferred] show "unique_factorization_m f (c, mset fs)" .
qed

text ‹We now have to implement @{const finite_field_factorization}.›  
context
  fixes p :: int
  and ff_ops :: "'i arith_ops_record"  (* finite-fields *)
begin

fun power_poly_f_mod_i :: "('i list  'i list)  'i list  nat  'i list" where
  "power_poly_f_mod_i modulus a n = (if n = 0 then modulus (one_poly_i ff_ops)
    else let (d,r) = Divides.divmod_nat n 2; 
       rec = power_poly_f_mod_i modulus (modulus (times_poly_i ff_ops a a)) d in 
    if r = 0 then rec else modulus (times_poly_i ff_ops rec a))"

declare power_poly_f_mod_i.simps[simp del]

fun power_polys_i :: "'i list  'i list  'i list  nat  'i list list" where
  "power_polys_i mul_p u curr_p (Suc i) = curr_p # 
      power_polys_i mul_p u (mod_field_poly_i ff_ops (times_poly_i ff_ops curr_p mul_p) u) i"
| "power_polys_i mul_p u curr_p 0 = []"

lemma length_power_polys_i[simp]: "length (power_polys_i x y z n) = n" 
  by (induct n arbitrary: x y z, auto)

definition berlekamp_mat_i :: "'i list  'i mat" where
  "berlekamp_mat_i u = (let n = degree_i u; 
    ze = arith_ops_record.zero ff_ops; on = arith_ops_record.one ff_ops;
    mul_p = power_poly_f_mod_i (λ v. mod_field_poly_i ff_ops v u) 
      [ze, on] (nat p);
    xks = power_polys_i mul_p u [on] n
   in mat_of_rows_list n (map (λ cs. cs @ replicate (n - length cs) ze) xks))"

definition berlekamp_resulting_mat_i :: "'i list  'i mat" where
"berlekamp_resulting_mat_i u = (let Q = berlekamp_mat_i u;
    n = dim_row Q;
    QI = mat n n (λ (i,j). if i = j then arith_ops_record.minus ff_ops (Q $$ (i,j)) (arith_ops_record.one ff_ops) else Q $$ (i,j))
    in (gauss_jordan_single_i ff_ops (transpose_mat QI)))"

definition berlekamp_basis_i :: "'i list  'i list list" where
  "berlekamp_basis_i u = (map (poly_of_list_i ff_ops o list_of_vec) 
    (find_base_vectors_i ff_ops (berlekamp_resulting_mat_i u)))"

primrec berlekamp_factorization_main_i :: "'i  'i  nat  'i list list  'i list list  nat  'i list list" where
  "berlekamp_factorization_main_i ze on d divs (v # vs) n = (
    if v = [on] then berlekamp_factorization_main_i ze on d divs vs n else
    if length divs = n then divs else
    let of_int = arith_ops_record.of_int ff_ops;
        facts = filter (λ w. w  [on]) 
          [ gcd_poly_i ff_ops u (minus_poly_i ff_ops v (if s = 0 then [] else [of_int (int s)])) . 
            u  divs, s  [0 ..< nat p]];
      (lin,nonlin) = List.partition (λ q. degree_i q = d) facts 
      in lin @ berlekamp_factorization_main_i ze on d nonlin vs (n - length lin))"
| "berlekamp_factorization_main_i ze on d divs [] n = divs"

definition berlekamp_monic_factorization_i :: "nat  'i list  'i list list" where
  "berlekamp_monic_factorization_i d f = (let
     vs = berlekamp_basis_i f
    in berlekamp_factorization_main_i (arith_ops_record.zero ff_ops) (arith_ops_record.one ff_ops) d [f] vs (length vs))"         

partial_function (tailrec) dist_degree_factorize_main_i :: 
  "'i  'i  nat  'i list  'i list  nat  (nat × 'i list) list 
   (nat × 'i list) list" where
  [code]: "dist_degree_factorize_main_i ze on dv v w d res = (if v = [on] then res else if d + d > dv 
    then (dv, v) # res else let
      w = power_poly_f_mod_i (λ f. mod_field_poly_i ff_ops f v) w (nat p);
      d = Suc d;
      gd = gcd_poly_i ff_ops (minus_poly_i ff_ops w [ze,on]) v
      in if gd = [on] then dist_degree_factorize_main_i ze on dv v w d res else 
      let v' = div_field_poly_i ff_ops v gd
      in dist_degree_factorize_main_i ze on (degree_i v') v' (mod_field_poly_i ff_ops w v') d ((d,gd) # res))" 

definition distinct_degree_factorization_i
  :: "'i list  (nat × 'i list) list" where
  "distinct_degree_factorization_i f = (let ze = arith_ops_record.zero ff_ops;
     on = arith_ops_record.one ff_ops in if degree_i f = 1 then [(1,f)] else 
     dist_degree_factorize_main_i ze on (degree_i f) f [ze,on] 0 [])"

definition finite_field_factorization_i :: "'i list  'i × 'i list list" where
  "finite_field_factorization_i f = (if degree_i f = 0 then (lead_coeff_i ff_ops f,[]) else let
     a = lead_coeff_i ff_ops f;
     u = smult_i ff_ops (arith_ops_record.inverse ff_ops a) f;
     gs = (if use_distinct_degree_factorization then distinct_degree_factorization_i u else [(1,u)]);
     (irr,hs) = List.partition (λ (i,f). degree_i f = i) gs
     in (a,map snd irr @ concat (map (λ (i,g). berlekamp_monic_factorization_i i g) hs)))"
end

context prime_field_gen
begin

lemma power_polys_i: assumes i: "i < n" and [transfer_rule]: "poly_rel f f'" "poly_rel g g'" 
  and h: "poly_rel h h'"
  shows "poly_rel (power_polys_i ff_ops g f h n ! i) (power_polys g' f' h' n ! i)"
  using i h
proof (induct n arbitrary: h h' i)
  case (Suc n h h' i) note * = this
  note [transfer_rule] = *(3)
  show ?case 
  proof (cases i)
    case 0
    with Suc show ?thesis by auto
  next
    case (Suc j)
    with *(2-) have "j < n" by auto
    note IH = *(1)[OF this]
    show ?thesis unfolding Suc by (simp, rule IH, transfer_prover)
  qed
qed simp

lemma power_poly_f_mod_i: assumes m: "(poly_rel ===> poly_rel) m (λ x'. x' mod m')"
  shows "poly_rel f f'  poly_rel (power_poly_f_mod_i ff_ops m f n) (power_poly_f_mod m' f' n)"
proof -
  from m have m: " x x'. poly_rel x x'  poly_rel (m x) (x' mod m')" 
    unfolding rel_fun_def by auto
  show "poly_rel f f'  poly_rel (power_poly_f_mod_i ff_ops m f n) (power_poly_f_mod m' f' n)"
  proof (induct n arbitrary: f f' rule: less_induct)
    case (less n f f')
    note f[transfer_rule] = less(2)
    show ?case
    proof (cases "n = 0")
      case True
      show ?thesis 
        by (simp add: True power_poly_f_mod_i.simps power_poly_f_mod_binary, 
          rule m[OF poly_rel_one])
    next
      case False
      hence n: "(n = 0) = False" by simp
      obtain q r where div: "Divides.divmod_nat n 2 = (q,r)" by force
      from this[unfolded divmod_nat_def] n have "q < n" by auto
      note IH = less(1)[OF this]
      have rec: "poly_rel (power_poly_f_mod_i ff_ops m (m (times_poly_i ff_ops f f)) q) 
        (power_poly_f_mod m' (f' * f' mod m') q)" 
        by (rule IH, rule m, transfer_prover)
      have other: "poly_rel 
        (m (times_poly_i ff_ops (power_poly_f_mod_i ff_ops m (m (times_poly_i ff_ops f f)) q) f))
        (power_poly_f_mod m' (f' * f' mod m') q * f' mod m')" 
        by (rule m, rule poly_rel_times[unfolded rel_fun_def, rule_format, OF rec f])
      show ?thesis unfolding power_poly_f_mod_i.simps[of _ _ _ n] Let_def 
        power_poly_f_mod_binary[of _ _ n] div split n if_False using rec other by auto
    qed
  qed
qed
    
lemma berlekamp_mat_i[transfer_rule]: "(poly_rel ===> mat_rel R) 
  (berlekamp_mat_i p ff_ops) berlekamp_mat"
proof (intro rel_funI)
  fix f f' 
  let ?ze = "arith_ops_record.zero ff_ops" 
  let ?on = "arith_ops_record.one ff_ops"
  assume f[transfer_rule]: "poly_rel f f'"
  have deg: "degree_i f = degree f'" by transfer_prover
  {
    fix i j
    assume i: "i < degree f'" and j: "j < degree f'" 
    define cs where "cs = (λcs :: 'i list. cs @ replicate (degree f' - length cs) ?ze)"
    define cs' where "cs' = (λcs :: 'a mod_ring poly. coeffs cs @ replicate (degree f' - length (coeffs cs)) 0)"
    define poly where "poly = power_polys_i ff_ops
         (power_poly_f_mod_i ff_ops (λv. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p)) f [?on]
         (degree f')"
    define poly' where "poly' = (power_polys (power_poly_f_mod f' [:0, 1:] (nat p)) f' 1 (degree f'))"
    have *: "poly_rel (power_poly_f_mod_i ff_ops (λv. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p))
      (power_poly_f_mod f' [:0, 1:] (nat p))" 
      by (rule power_poly_f_mod_i, transfer_prover, simp add: poly_rel_def one zero)
    have [transfer_rule]: "poly_rel (poly ! i) (poly' ! i)" 
      unfolding poly_def poly'_def 
      by (rule power_polys_i[OF i f *], simp add: poly_rel_def one)
    have *: "list_all2 R (cs (poly ! i)) (cs' (poly' ! i))"
      unfolding cs_def cs'_def by transfer_prover
    from list_all2_nthD[OF *[unfolded poly_rel_def], of j] j
    have "R (cs (poly ! i) ! j) (cs' (poly' ! i) ! j)" unfolding cs_def by auto
    hence "R
            (mat_of_rows_list (degree f')
              (map (λcs. cs @ replicate (degree f' - length cs) ?ze)
                (power_polys_i ff_ops
                  (power_poly_f_mod_i ff_ops (λv. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p)) f [?on]
                  (degree f'))) $$
             (i, j))
            (mat_of_rows_list (degree f')
              (map (λcs. coeffs cs @ replicate (degree f' - length (coeffs cs)) 0)
                (power_polys (power_poly_f_mod f' [:0, 1:] (nat p)) f' 1 (degree f'))) $$
             (i, j))"           
        unfolding mat_of_rows_list_def length_map length_power_polys_i power_polys_works
          length_power_polys index_mat[OF i j] split
        unfolding poly_def cs_def poly'_def cs'_def using i
        by auto
  } note main = this
  show "mat_rel R (berlekamp_mat_i p ff_ops f) (berlekamp_mat f')"
    unfolding berlekamp_mat_i_def berlekamp_mat_def Let_def nat_p[symmetric] deg
    unfolding mat_rel_def
    by (intro conjI allI impI, insert main, auto)
qed

lemma berlekamp_resulting_mat_i[transfer_rule]: "(poly_rel ===> mat_rel R) 
  (berlekamp_resulting_mat_i p ff_ops) berlekamp_resulting_mat"
proof (intro rel_funI)
  fix f f'
  assume "poly_rel f f'"
  from berlekamp_mat_i[unfolded rel_fun_def, rule_format, OF this]
  have bmi: "mat_rel R (berlekamp_mat_i p ff_ops f) (berlekamp_mat f')" .
  show "mat_rel R (berlekamp_resulting_mat_i p ff_ops f) (berlekamp_resulting_mat f')"
    unfolding berlekamp_resulting_mat_def Let_def berlekamp_resulting_mat_i_def
    by (rule gauss_jordan_i[unfolded rel_fun_def, rule_format],
    insert bmi, auto simp: mat_rel_def one intro!: minus[unfolded rel_fun_def, rule_format])
qed

lemma berlekamp_basis_i[transfer_rule]: "(poly_rel ===> list_all2 poly_rel) 
  (berlekamp_basis_i p ff_ops) berlekamp_basis"
  unfolding berlekamp_basis_i_def[abs_def] berlekamp_basis_code[abs_def] o_def
  by transfer_prover

lemma berlekamp_factorization_main_i[transfer_rule]: 
  "((=) ===> list_all2 poly_rel ===> list_all2 poly_rel ===> (=) ===> list_all2 poly_rel) 
     (berlekamp_factorization_main_i p ff_ops (arith_ops_record.zero ff_ops) 
       (arith_ops_record.one ff_ops)) 
     berlekamp_factorization_main" 
proof (intro rel_funI, clarify, goal_cases)
  case (1 _ d xs xs' ys ys' _ n)
  let ?ze = "arith_ops_record.zero ff_ops" 
  let ?on = "arith_ops_record.one ff_ops"
  let ?of_int = "arith_ops_record.of_int ff_ops"
  from 1(2) 1(1) show ?case
  proof (induct ys ys' arbitrary: xs xs' n rule: list_all2_induct)   
    case (Cons y ys y' ys' xs xs' n)
    note trans[transfer_rule] = Cons(1,2,4)
    obtain clar0 clar1 clar2 where clarify: " s u. gcd_poly_i ff_ops u
                         (minus_poly_i ff_ops y
                        (if s = 0 then [] else [?of_int (int s)])) = clar0 s u" 
        "[0..<nat p] = clar1"
        "[?on] = clar2" by auto
    define facts where "facts = concat (map (λu. concat
                        (map (λs. if gcd_poly_i ff_ops u
                                      (minus_poly_i ff_ops y (if s = 0 then [] else [?of_int (int s)])) 
                                     [?on]
                                  then [gcd_poly_i ff_ops u
                                         (minus_poly_i ff_ops y (if s = 0 then [] else [?of_int (int s)]))]
                                  else [])
                          [0..<nat p])) xs)"
    define Facts where "Facts = [wconcat
                          (map (λu. map (λs. gcd_poly_i ff_ops u
                                              (minus_poly_i ff_ops y
                                                (if s = 0 then [] else [?of_int (int s)])))
                                     [0..<nat p])
                            xs) .  w  [?on]]"
    have Facts: "Facts = facts"
      unfolding Facts_def facts_def clarify
    proof (induct xs)
      case (Cons x xs)
      show ?case by (simp add: Cons, induct clar1, auto)
    qed simp
    define facts' where "facts' = concat
             (map (λu. concat
                        (map (λx. if gcd u (y' - [:of_nat x:])  1
                                  then [gcd u (y' - [:of_int (int x):])] else [])
                          [0..<nat p]))
               xs')" 
    have id: " x. of_int (int x) = of_nat x" "[?on] = one_poly_i ff_ops" 
      by (auto simp: one_poly_i_def) 
    have facts[transfer_rule]: "list_all2 poly_rel facts facts'"
      unfolding facts_def facts'_def
    apply (rule concat_transfer[unfolded rel_fun_def, rule_format])
    apply (rule list.map_transfer[unfolded rel_fun_def, rule_format, OF _ trans(3)])
    apply (rule concat_transfer[unfolded rel_fun_def, rule_format])
    apply (rule list_all2_map_map)
    proof (unfold id)
      fix f f' x
      assume [transfer_rule]: "poly_rel f f'" and x: "x  set [0..<nat p]"
      hence *: "0  int x" "int x < p" by auto
      from of_int[OF this] have rel[transfer_rule]: "R (?of_int (int x)) (of_nat x)" by auto
      {
        assume "0 < x" 
        with * have *: "0 < int x" "int x < p" by auto
        have "(of_nat x :: 'a mod_ring) = of_int (int x)" by simp
        also have "  0" unfolding of_int_of_int_mod_ring using * unfolding p
          by (transfer', auto)
      }
      with rel have [transfer_rule]: "poly_rel (if x = 0 then [] else [?of_int (int x)]) [:of_nat x:]"
        unfolding poly_rel_def by (auto simp add: cCons_def p)
      show "list_all2 poly_rel
          (if gcd_poly_i ff_ops f (minus_poly_i ff_ops y (if x = 0 then [] else [?of_int (int x)]))  one_poly_i ff_ops
           then [gcd_poly_i ff_ops f (minus_poly_i ff_ops y (if x = 0 then [] else [?of_int (int x)]))]
           else [])
          (if gcd f' (y' - [:of_nat x:])  1 then [gcd f' (y' - [:of_nat x:])] else [])"
        by transfer_prover
    qed
    have id1: "berlekamp_factorization_main_i p ff_ops ?ze ?on d xs (y # ys) n = (
      if y = [?on] then berlekamp_factorization_main_i p ff_ops ?ze ?on d xs ys n else
      if length xs = n then xs else
      (let fac = facts;
          (lin, nonlin) = List.partition (λq. degree_i q = d) fac
             in lin @ berlekamp_factorization_main_i p ff_ops ?ze ?on d nonlin ys (n - length lin)))" 
      unfolding berlekamp_factorization_main_i.simps Facts[symmetric]
      by (simp add: o_def Facts_def Let_def)
    have id2: "berlekamp_factorization_main d xs' (y' # ys') n = (
      if y' = 1 then berlekamp_factorization_main d xs' ys' n
      else if length xs' = n then xs' else
      (let fac = facts';
          (lin, nonlin) = List.partition (λq. degree q = d) fac
              in lin @ berlekamp_factorization_main d nonlin ys' (n - length lin)))"
      by (simp add: o_def facts'_def nat_p)
    have len: "length xs = length xs'" by transfer_prover
    have id3: "(y = [?on]) = (y' = 1)" 
      by (transfer_prover_start, transfer_step+, simp add: one_poly_i_def finite_field_ops_int_def)
    show ?case
    proof (cases "y' = 1")
      case True
      hence id4: "(y' = 1) = True" by simp
      show ?thesis unfolding id1 id2 id3 id4 if_True
        by (rule Cons(3), transfer_prover)
    next
      case False
      hence id4: "(y' = 1) = False" by simp
      note id1 = id1[unfolded id3 id4 if_False]
      note id2 = id2[unfolded id4 if_False]
      show ?thesis
      proof (cases "length xs' = n")
        case True
        thus ?thesis unfolding id1 id2 Let_def len using trans by simp
      next
        case False
        hence id: "(length xs' = n) = False" by simp
        have id': "length [qfacts . degree_i q = d] = length [qfacts'. degree q = d]" 
          by transfer_prover   
        have [transfer_rule]: "list_all2 poly_rel (berlekamp_factorization_main_i p ff_ops ?ze ?on d [xfacts . degree_i x  d] ys
         (n - length [qfacts . degree_i q = d])) 
         (berlekamp_factorization_main d [xfacts' . degree x  d] ys'
         (n - length [qfacts' . degree q = d]))"
          unfolding id'
          by (rule Cons(3), transfer_prover)
        show ?thesis unfolding id1 id2 Let_def len id if_False
          unfolding partition_filter_conv o_def split by transfer_prover
      qed
    qed
  qed simp
qed
    
lemma berlekamp_monic_factorization_i[transfer_rule]: 
  "((=) ===> poly_rel ===> list_all2 poly_rel) 
     (berlekamp_monic_factorization_i p ff_ops) berlekamp_monic_factorization" 
  unfolding berlekamp_monic_factorization_i_def[abs_def] berlekamp_monic_factorization_def[abs_def] Let_def
  by transfer_prover

lemma dist_degree_factorize_main_i: 
  "poly_rel F f  poly_rel G g  list_all2 (rel_prod (=) poly_rel) Res res 
    list_all2 (rel_prod (=) poly_rel) 
      (dist_degree_factorize_main_i p ff_ops 
         (arith_ops_record.zero ff_ops) (arith_ops_record.one ff_ops) (degree_i F) F G d Res)
      (dist_degree_factorize_main f g d res)" 
proof (induct f g d res arbitrary: F G Res rule: dist_degree_factorize_main.induct)
  case (1 v w d res V W Res)
  let ?ze = "arith_ops_record.zero ff_ops" 
  let ?on = "arith_ops_record.one ff_ops"
  note simp = dist_degree_factorize_main.simps[of v w d] 
    dist_degree_factorize_main_i.simps[of p ff_ops ?ze ?on "degree_i V" V W d]
  have v[transfer_rule]: "poly_rel V v" by (rule 1)
  have w[transfer_rule]: "poly_rel W w" by (rule 1)
  have res[transfer_rule]: "list_all2 (rel_prod (=) poly_rel) Res res" by (rule 1)
  have [transfer_rule]: "poly_rel [?on] 1"
    by (simp add: one poly_rel_def)
  have id1: "(V = [?on]) = (v = 1)" unfolding finite_field_ops_int_def by transfer_prover
  have id2: "degree_i V = degree v" by transfer_prover
  note simp = simp[unfolded id1 id2]
  note IH = 1(1,2)
  show ?case 
  proof (cases "v = 1")
    case True
    with res show ?thesis unfolding id2 simp by simp
  next
    case False
    with id1 have "(v = 1) = False" by auto
    note simp = simp[unfolded this if_False]
    note IH = IH[OF False]
    show ?thesis
    proof (cases "degree v < d + d")
      case True
      thus ?thesis unfolding id2 simp using res v by auto
    next
      case False
      hence "(degree v < d + d) = False" by auto
      note simp = simp[unfolded this if_False]
      let ?P = "power_poly_f_mod_i ff_ops (λf. mod_field_poly_i ff_ops f V) W (nat p)" 
      let ?G = "gcd_poly_i ff_ops (minus_poly_i ff_ops ?P [?ze, ?on]) V" 
      let ?g = "gcd (w ^ CARD('a) mod v - monom 1 1) v" 
      define G where "G = ?G" 
      define g where "g = ?g"
      note simp = simp[unfolded Let_def, folded G_def g_def]
      note IH = IH[OF False refl refl refl]
      have [transfer_rule]: "poly_rel [?ze,?on] (monom 1 1)" unfolding poly_rel_def
        by (auto simp: coeffs_monom one zero)
      have id: "w ^ CARD('a) mod v = power_poly_f_mod v w (nat p)"
        unfolding power_poly_f_mod_def by (simp add: p)
      have P[transfer_rule]: "poly_rel ?P (w ^ CARD('a) mod v)" unfolding id
        by (rule power_poly_f_mod_i[OF _ w], transfer_prover)
      have g[transfer_rule]: "poly_rel G g" unfolding G_def g_def by transfer_prover
      have id3: "(G = [?on]) = (g = 1)" by transfer_prover
      note simp = simp[unfolded id3]
      show ?thesis
      proof (cases "g = 1")
        case True
        from IH(1)[OF this[unfolded g_def] v P res] True
        show ?thesis unfolding id2 simp by simp
      next
        case False
        have vg: "poly_rel (div_field_poly_i ff_ops V G) (v div g)" by transfer_prover
        have "poly_rel (mod_field_poly_i ff_ops ?P
          (div_field_poly_i ff_ops V G)) (w ^ CARD('a) mod v mod (v div g))" by transfer_prover        
        note IH = IH(2)[OF False[unfolded g_def] refl vg[unfolded G_def g_def] this[unfolded G_def g_def],
            folded g_def G_def]
        have "list_all2 (rel_prod (=) poly_rel) ((Suc d, G) # Res) ((Suc d, g) # res)" 
          using g res by auto
        note IH = IH[OF this]
        from False have "(g = 1) = False" by simp
        note simp = simp[unfolded this if_False]
        show ?thesis unfolding id2 simp using IH by simp
      qed
    qed
  qed
qed
      
lemma distinct_degree_factorization_i[transfer_rule]: "(poly_rel ===> list_all2 (rel_prod (=) poly_rel)) 
  (distinct_degree_factorization_i p ff_ops) distinct_degree_factorization"
proof 
  fix F f
  assume f[transfer_rule]: "poly_rel F f" 
  have id: "(degree_i F = 1) = (degree f = 1)" by transfer_prover
  note d = distinct_degree_factorization_i_def distinct_degree_factorization_def
  let ?ze = "arith_ops_record.zero ff_ops" 
  let ?on = "arith_ops_record.one ff_ops"
  show "list_all2 (rel_prod (=) poly_rel) (distinct_degree_factorization_i p ff_ops F)
            (distinct_degree_factorization f)" 
  proof (cases "degree f = 1")
    case True
    with id f show ?thesis unfolding d by auto
  next
    case False
    from False id have "?thesis = (list_all2 (rel_prod (=) poly_rel) 
      (dist_degree_factorize_main_i p ff_ops ?ze ?on (degree_i F) F [?ze, ?on] 0 [])
      (dist_degree_factorize_main f (monom 1 1) 0 []))" unfolding d Let_def by simp    
    also have 
      by (rule dist_degree_factorize_main_i[OF f], auto simp: poly_rel_def
        coeffs_monom one zero)
    finally show ?thesis .
  qed
qed

lemma finite_field_factorization_i[transfer_rule]: 
  "(poly_rel ===> rel_prod R (list_all2 poly_rel))
     (finite_field_factorization_i p ff_ops) finite_field_factorization" 
  unfolding finite_field_factorization_i_def finite_field_factorization_def Let_def lead_coeff_i_def'
  by transfer_prover

text ‹Since the implementation is sound, we can now combine it with the soundness result
  of the finite field factorization.›

lemma finite_field_i_sound: 
  assumes f': "f' = of_int_poly_i ff_ops (Mp f)" 
  and berl_i: "finite_field_factorization_i p ff_ops f' = (c',fs')"
  and sq: "square_free_m f" 
  and fs: "fs = map (to_int_poly_i ff_ops) fs'"
  and c: "c = arith_ops_record.to_int ff_ops c'" 
  shows "unique_factorization_m f (c, mset fs)
     c  {0 ..< p} 
     ( fi  set fs. set (coeffs fi)  {0 ..< p})" 
proof -
  define f'' :: "'a mod_ring poly" where "f'' = of_int_poly (Mp f)"
  have rel_f[transfer_rule]: "poly_rel f' f''" 
    by (rule poly_rel_of_int_poly[OF f'], simp add: f''_def)
  interpret pff: idom_ops "poly_ops ff_ops" poly_rel 
    by (rule idom_ops_poly)
  obtain c'' fs'' where berl: "finite_field_factorization f'' = (c'',fs'')" by force
  from rel_funD[OF finite_field_factorization_i rel_f, unfolded rel_prod_conv assms(2) split berl]
  have rel[transfer_rule]: "R c' c''" "list_all2 poly_rel fs' fs''" by auto  
  from to_int[OF rel(1)] have cc': "c = to_int_mod_ring c''" unfolding c by simp
  have c: "c  {0 ..< p}" unfolding cc'
    by (metis Divides.pos_mod_bound Divides.pos_mod_sign M_to_int_mod_ring atLeastLessThan_iff 
      gr_implies_not_zero nat_le_0 nat_p not_le poly_mod.M_def zero_less_card_finite)
  {
    fix f
    assume "f  set fs'" 
    with rel(2) obtain f' where "poly_rel f f'"  unfolding list_all2_conv_all_nth set_conv_nth
      by auto
    hence "is_poly ff_ops f" using fun_cong[OF Domainp_is_poly, of f]
      unfolding Domainp_iff[abs_def] by auto
  }
  hence fs': "Ball (set fs') (is_poly ff_ops)" by auto
  define mon :: "'a mod_ring poly  bool" where "mon = monic"
  have [transfer_rule]: "(poly_rel ===> (=)) (monic_i ff_ops) mon" unfolding mon_def 
    by (rule poly_rel_monic)
  have len: "length fs' = length fs''" by transfer_prover
  have fs': "fs = map to_int_poly fs''" unfolding fs 
  proof (rule nth_map_conv[OF len], intro allI impI)
    fix i
    assume i: "i < length fs'" 
    obtain f g where id: "fs' ! i = f" "fs'' ! i = g" by auto
    from i rel(2)[unfolded list_all2_conv_all_nth[of _ fs' fs'']] id
    have "poly_rel f g" by auto
    from to_int_poly_i[OF this] have "to_int_poly_i ff_ops f = to_int_poly g" .
    thus "to_int_poly_i ff_ops (fs' ! i) = to_int_poly (fs'' ! i)" unfolding id .
  qed
  have f: "f'' = of_int_poly f" unfolding poly_eq_iff f''_def
    by (simp add: to_int_mod_ring_hom.injectivity to_int_mod_ring_of_int_M Mp_coeff)
  have *: "unique_factorization_m f (c, mset fs)" 
    using finite_field_factorization_modulo_ring[OF f sq berl cc' fs'] by auto
  have fs': "(fiset fs. set (coeffs fi)  {0..<p})" unfolding fs' 
    using range_to_int_mod_ring[where 'a = 'a]
    by (auto simp: coeffs_to_int_poly p)
  with c fs *
  show ?thesis by blast
qed
end

definition finite_field_factorization_main :: "int  'i arith_ops_record  int poly  int × int poly list" where
  "finite_field_factorization_main p f_ops f  
    let (c',fs') = finite_field_factorization_i p f_ops (of_int_poly_i f_ops (poly_mod.Mp p f))
      in (arith_ops_record.to_int f_ops c', map (to_int_poly_i f_ops) fs')"

lemma(in prime_field_gen) finite_field_factorization_main: 
  assumes res: "finite_field_factorization_main p ff_ops f = (c,fs)"
  and sq: "square_free_m f" 
  shows "unique_factorization_m f (c, mset fs)
     c  {0 ..< p} 
     ( fi  set fs. set (coeffs fi)  {0 ..< p})"
proof -
  obtain c' fs' where 
    res': "finite_field_factorization_i p ff_ops (of_int_poly_i ff_ops (Mp f)) = (c', fs')"  by force
  show ?thesis  
    by (rule finite_field_i_sound[OF refl res' sq], 
      insert res[unfolded finite_field_factorization_main_def res'], auto)
qed

definition finite_field_factorization_int :: "int  int poly  int × int poly list" where
  "finite_field_factorization_int p = (  
    if p  65535 
    then finite_field_factorization_main p (finite_field_ops32 (uint32_of_int p))
    else if p  4294967295
    then finite_field_factorization_main p (finite_field_ops64 (uint64_of_int p))
    else finite_field_factorization_main p (finite_field_ops_integer (integer_of_int p)))"

context poly_mod_prime begin
lemmas finite_field_factorization_main_integer = prime_field_gen.finite_field_factorization_main
  [OF prime_field.prime_field_finite_field_ops_integer, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas finite_field_factorization_main_uint32 = prime_field_gen.finite_field_factorization_main
  [OF prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas finite_field_factorization_main_uint64 = prime_field_gen.finite_field_factorization_main
  [OF prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma finite_field_factorization_int:
  assumes sq: "poly_mod.square_free_m p f" 
  and result: "finite_field_factorization_int p f = (c,fs)"
  shows "poly_mod.unique_factorization_m p f (c, mset fs)
     c  {0 ..< p} 
     ( fi  set fs. set (coeffs fi)  {0 ..< p})" 
  using finite_field_factorization_main_integer[OF  _ sq, of c fs]
    finite_field_factorization_main_uint32[OF _ _ sq, of c fs]
    finite_field_factorization_main_uint64[OF _ _ sq, of c fs]
    result[unfolded finite_field_factorization_int_def]
  by (auto split: if_splits)

end

end

Theory Hensel_Lifting

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹Hensel Lifting›

subsection ‹Properties about Factors›

text ‹We define and prove properties of Hensel-lifting. Here, we show the result that 
  Hensel-lifting can lift a factorization mod $p$ to a factorization mod $p^n$. 
  For the lifting we have proofs for both versions, the original linear Hensel-lifting or 
  the quadratic approach from Zassenhaus. 
  Via the linear version, we also show a uniqueness result, however only in the 
  binary case, i.e., where $f = g \cdot h$. Uniqueness of the general case will later be shown 
  in theory Berlekamp-Hensel by incorporating the factorization algorithm for finite fields algorithm.›

theory Hensel_Lifting
imports 
  "HOL-Computational_Algebra.Euclidean_Algorithm"
  Poly_Mod_Finite_Field_Record_Based
  Polynomial_Factorization.Square_Free_Factorization
begin


lemma uniqueness_poly_equality:
  fixes f g :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  assumes cop: "coprime f g"
  and deg: "B = 0  degree B < degree f" "B' = 0  degree B' < degree f"
  and f: "f  0" and eq: "A * f + B * g = A' * f + B' * g" 
  shows "A = A'" "B = B'" 
proof -
  from eq have *: "(A - A') * f = (B' - B) * g" by (simp add: field_simps)
  hence "f dvd (B' - B) * g" unfolding dvd_def by (intro exI[of _ "A - A'"], auto simp: field_simps)
  with cop[simplified] have dvd: "f dvd (B' - B)"
    by (simp add: coprime_dvd_mult_right_iff ac_simps)
  from divides_degree[OF this] have "degree f  degree (B' - B)  B = B'" by auto
  with degree_diff_le_max[of B' B] deg 
  show "B = B'" by auto
  with * f show "A = A'" by auto
qed

lemmas (in poly_mod_prime_type) uniqueness_poly_equality =
  uniqueness_poly_equality[where 'a="'a mod_ring", untransferred]
lemmas (in poly_mod_prime) uniqueness_poly_equality = poly_mod_prime_type.uniqueness_poly_equality
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma pseudo_divmod_main_list_1_is_divmod_poly_one_main_list: 
  "pseudo_divmod_main_list (1 :: 'a :: comm_ring_1) q f g n = divmod_poly_one_main_list q f g n"
  by (induct n arbitrary: q f g, auto simp: Let_def)

lemma pdivmod_monic_pseudo_divmod: assumes g: "monic g" shows "pdivmod_monic f g = pseudo_divmod f g" 
proof -
  from g have id: "(coeffs g = []) = False" by auto
  from g have mon: "hd (rev (coeffs g)) = 1" by (metis coeffs_eq_Nil hd_rev id last_coeffs_eq_coeff_degree)
  show ?thesis
    unfolding pseudo_divmod_impl pseudo_divmod_list_def id if_False pdivmod_monic_def Let_def mon
      pseudo_divmod_main_list_1_is_divmod_poly_one_main_list by (auto split: prod.splits)
qed

lemma pdivmod_monic: assumes g: "monic g" and res: "pdivmod_monic f g = (q, r)"
  shows "f = g * q + r" "r = 0  degree r < degree g"
proof -
  from g have g0: "g  0" by auto
  from pseudo_divmod[OF g0 res[unfolded pdivmod_monic_pseudo_divmod[OF g]], unfolded g]
  show "f = g * q + r" "r = 0  degree r < degree g" by auto
qed

definition dupe_monic :: "'a :: comm_ring_1  poly  'a poly  'a poly  'a poly  'a poly 
  'a poly * 'a poly" where
  "dupe_monic D H S T U = (case pdivmod_monic (T * U) D of (q,r) 
     (S * U + H * q, r))"

lemma dupe_monic: assumes 1: "D*S + H*T = 1" 
  and mon: "monic D" 
  and dupe: "dupe_monic D H S T U = (A,B)" 
shows "A * D + B * H = U" "B = 0  degree B < degree D"
proof -
  obtain Q R where div: "pdivmod_monic ((T * U)) D = (Q,R)" by force
  from dupe[unfolded dupe_monic_def div split]
  have A: "A = (S * U + H * Q)" and B: "B = R" by auto
  from pdivmod_monic[OF mon div] have TU: "T * U = D * Q + R" and 
    deg: "R = 0  degree R < degree D" by auto
  hence R: "R = T * U - D * Q" by simp
  have "A * D + B * H = (D * S + H * T) * U" unfolding A B R by (simp add: field_simps)
  also have " = U" unfolding 1 by simp
  finally show eq: "A * D + B * H = U" .
  show "B = 0  degree B < degree D" using deg unfolding B .
qed

lemma dupe_monic_unique: fixes D :: "'a ::  {factorial_ring_gcd,semiring_gcd_mult_normalize} poly" 
  assumes 1: "D*S + H*T = 1" 
  and mon: "monic D" 
  and dupe: "dupe_monic D H S T U = (A,B)" 
  and cop: "coprime D H"
  and other: "A' * D + B' * H = U" "B' = 0  degree B' < degree D"
shows "A' = A" "B' = B"
proof -
  from dupe_monic[OF 1 mon dupe] have one: "A * D + B * H = U" "B = 0  degree B < degree D" by auto
  from mon have D0: "D  0" by auto
  from uniqueness_poly_equality[OF cop one(2) other(2) D0, of A A', unfolded other, OF one(1)] 
  show "A' = A" "B' = B" by auto
qed

context ring_ops
begin
lemma poly_rel_dupe_monic_i: assumes mon: "monic D" 
  and rel: "poly_rel d D" "poly_rel h H" "poly_rel s S" "poly_rel t T" "poly_rel u U" 
shows "rel_prod poly_rel poly_rel (dupe_monic_i ops d h s t u) (dupe_monic D H S T U)" 
proof -
  note defs = dupe_monic_i_def dupe_monic_def
  note [transfer_rule] = rel
  have [transfer_rule]: "rel_prod poly_rel poly_rel 
    (pdivmod_monic_i ops (times_poly_i ops t u) d) 
    (pdivmod_monic (T * U) D)" 
    by (rule poly_rel_pdivmod_monic[OF mon], transfer_prover+)
  show ?thesis unfolding defs by transfer_prover
qed
end
              
context mod_ring_gen
begin 

lemma monic_of_int_poly: "monic D  monic (of_int_poly (Mp D) :: 'a mod_ring poly)"
  using Mp_f_representative Mp_to_int_poly monic_Mp by auto

lemma dupe_monic_i: assumes dupe_i: "dupe_monic_i ff_ops d h s t u = (a,b)" 
  and 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and A: "A = to_int_poly_i ff_ops a" 
  and B: "B = to_int_poly_i ff_ops b" 
  and d: "Mp_rel_i d D" 
  and h: "Mp_rel_i h H" 
  and s: "Mp_rel_i s S" 
  and t: "Mp_rel_i t T" 
  and u: "Mp_rel_i u U" 
shows 
  "A * D + B * H =m U" 
  "B = 0  degree B < degree D" 
  "Mp_rel_i a A" 
  "Mp_rel_i b B"
proof -
  let ?I = "λ f. of_int_poly (Mp f) :: 'a mod_ring poly" 
  let ?i = "to_int_poly_i ff_ops" 
  note dd = Mp_rel_iD[OF d]
  note hh = Mp_rel_iD[OF h]
  note ss = Mp_rel_iD[OF s]
  note tt = Mp_rel_iD[OF t]
  note uu = Mp_rel_iD[OF u]  
  obtain A' B' where dupe: "dupe_monic (?I D) (?I H) (?I S) (?I T) (?I U) = (A',B')"  by force
  from poly_rel_dupe_monic_i[OF monic_of_int_poly[OF mon] dd(1) hh(1) ss(1) tt(1) uu(1), unfolded dupe_i dupe]
  have a: "poly_rel a A'" and b: "poly_rel b B'" by auto
  show aa: "Mp_rel_i a A" by (rule Mp_rel_iI'[OF a, folded A])
  show bb: "Mp_rel_i b B" by (rule Mp_rel_iI'[OF b, folded B])
  note Aa = Mp_rel_iD[OF aa]
  note Bb = Mp_rel_iD[OF bb]
  from poly_rel_inj[OF a Aa(1)] A have A: "A' = ?I A" by simp
  from poly_rel_inj[OF b Bb(1)] B have B: "B' = ?I B" by simp
  note Mp = dd(2) hh(2) ss(2) tt(2) uu(2)
  note [transfer_rule] = Mp
  have "(=) (D * S + H * T =m 1) (?I D * ?I S + ?I H * ?I T = 1)" by transfer_prover
  with 1 have 11: "?I D * ?I S + ?I H * ?I T = 1" by simp
  from dupe_monic[OF 11 monic_of_int_poly[OF mon] dupe, unfolded A B]
  have res: "?I A * ?I D + ?I B * ?I H = ?I U" "?I B = 0  degree (?I B) < degree (?I D)" by auto  
  note [transfer_rule] = Aa(2) Bb(2)
  have "(=) (A * D + B * H =m U) (?I A * ?I D + ?I B * ?I H = ?I U)"
       "(=) (B =m 0  degree_m B < degree_m D) (?I B = 0  degree (?I B) < degree (?I D))" by transfer_prover+
  with res have *: "A * D + B * H =m U" "B =m 0  degree_m B < degree_m D" by auto
  show "A * D + B * H =m U" by fact
  have B: "Mp B = B" using Mp_rel_i_Mp_to_int_poly_i assms(5) bb by blast
  from *(2) show "B = 0  degree B < degree D" unfolding B using degree_m_le[of D] by auto
qed

lemma Mp_rel_i_of_int_poly_i: assumes "Mp F = F"
  shows "Mp_rel_i (of_int_poly_i ff_ops F) F" 
  by (metis Mp_f_representative Mp_rel_iI' assms poly_rel_of_int_poly to_int_poly_i)

lemma dupe_monic_i_int: assumes dupe_i: "dupe_monic_i_int ff_ops D H S T U = (A,B)" 
  and 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U" 
shows 
  "A * D + B * H =m U" 
  "B = 0  degree B < degree D" 
  "Mp A = A" 
  "Mp B = B" 
proof -
  let ?oi = "of_int_poly_i ff_ops" 
  let ?ti = "to_int_poly_i ff_ops"
  note rel = norm[THEN Mp_rel_i_of_int_poly_i]
  obtain a b where dupe: "dupe_monic_i ff_ops (?oi D) (?oi H) (?oi S) (?oi T) (?oi U) = (a,b)" by force
  from dupe_i[unfolded dupe_monic_i_int_def this Let_def] have AB: "A = ?ti a" "B = ?ti b" by auto
  from dupe_monic_i[OF dupe 1 mon AB rel] Mp_rel_i_Mp_to_int_poly_i 
  show "A * D + B * H =m U" 
    "B = 0  degree B < degree D" 
    "Mp A = A" 
    "Mp B = B"
    unfolding AB by auto
qed

end

definition dupe_monic_dynamic 
  :: "int  int poly  int poly  int poly  int poly  int poly  int poly × int poly" where
  "dupe_monic_dynamic p = ( 
    if p  65535 
    then dupe_monic_i_int (finite_field_ops32 (uint32_of_int p))
    else if p  4294967295
    then dupe_monic_i_int (finite_field_ops64 (uint64_of_int p))
    else dupe_monic_i_int (finite_field_ops_integer (integer_of_int p)))" 

context poly_mod_2
begin

lemma dupe_monic_i_int_finite_field_ops_integer: assumes 
      dupe_i: "dupe_monic_i_int (finite_field_ops_integer (integer_of_int m)) D H S T U = (A,B)" 
  and 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U" 
shows 
  "A * D + B * H =m U" 
  "B = 0  degree B < degree D" 
  "Mp A = A" 
  "Mp B = B" 
  using m1 mod_ring_gen.dupe_monic_i_int[OF 
        mod_ring_locale.mod_ring_finite_field_ops_integer[unfolded mod_ring_locale_def], 
        internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, 
        cancel_type_definition, OF _ assms] by auto

lemma dupe_monic_i_int_finite_field_ops32: assumes 
      m: "m  65535"
  and dupe_i: "dupe_monic_i_int (finite_field_ops32 (uint32_of_int m)) D H S T U = (A,B)" 
  and 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U" 
shows 
  "A * D + B * H =m U" 
  "B = 0  degree B < degree D" 
  "Mp A = A" 
  "Mp B = B" 
  using m1 mod_ring_gen.dupe_monic_i_int[OF 
        mod_ring_locale.mod_ring_finite_field_ops32[unfolded mod_ring_locale_def], 
        internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, 
        cancel_type_definition, OF _ assms] by auto

lemma dupe_monic_i_int_finite_field_ops64: assumes 
      m: "m  4294967295"
  and dupe_i: "dupe_monic_i_int (finite_field_ops64 (uint64_of_int m)) D H S T U = (A,B)" 
  and 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U" 
shows 
  "A * D + B * H =m U" 
  "B = 0  degree B < degree D" 
  "Mp A = A" 
  "Mp B = B" 
  using m1 mod_ring_gen.dupe_monic_i_int[OF 
        mod_ring_locale.mod_ring_finite_field_ops64[unfolded mod_ring_locale_def], 
        internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, 
        cancel_type_definition, OF _ assms] by auto

lemma dupe_monic_dynamic: assumes dupe: "dupe_monic_dynamic m D H S T U = (A,B)" 
  and 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U" 
shows 
  "A * D + B * H =m U" 
  "B = 0  degree B < degree D" 
  "Mp A = A" 
  "Mp B = B"
  using dupe
    dupe_monic_i_int_finite_field_ops32[OF _ _ 1 mon norm, of A B]
    dupe_monic_i_int_finite_field_ops64[OF _ _ 1 mon norm, of A B]
    dupe_monic_i_int_finite_field_ops_integer[OF _ 1 mon norm, of A B]
  unfolding dupe_monic_dynamic_def by (auto split: if_splits)
end


context poly_mod
begin

definition dupe_monic_int :: "int poly  int poly  int poly  int poly  int poly  
  int poly * int poly" where
  "dupe_monic_int D H S T U = (case pdivmod_monic (Mp (T * U)) D of (q,r) 
     (Mp (S * U + H * q), Mp r))"

end

declare poly_mod.dupe_monic_int_def[code]

text ‹Old direct proof on int poly. 
  It does not permit to change implementation.
  This proof is still present, since we did not export the uniqueness part
  from the type-based uniqueness result @{thm dupe_monic_unique} via the various relations.›

lemma (in poly_mod_2) dupe_monic_int: assumes 1: "D*S + H*T =m 1" 
  and mon: "monic D" 
  and dupe: "dupe_monic_int D H S T U = (A,B)" 
  shows "A * D + B * H =m U" "B = 0  degree B < degree D" "Mp A = A" "Mp B = B" 
    "coprime_m D H  A' * D + B' * H =m U  B' = 0  degree B' < degree D  Mp D = D 
     Mp A' = A'  Mp B' = B'  prime m
     A' = A  B' = B"
proof -
  obtain Q R where div: "pdivmod_monic (Mp (T * U)) D = (Q,R)" by force
  from dupe[unfolded dupe_monic_int_def div split]
  have A: "A = Mp (S * U + H * Q)" and B: "B = Mp R" by auto
  from pdivmod_monic[OF mon div] have TU: "Mp (T * U) = D * Q + R" and 
    deg: "R = 0  degree R < degree D" by auto
  hence "Mp R = Mp (Mp (T * U) - D * Q)" by simp
  also have " = Mp (T * U - Mp (Mp (Mp D * Q)))" unfolding Mp_Mp unfolding minus_Mp
    using minus_Mp mult_Mp by metis
  also have " = Mp (T * U - D * Q)" by simp
  finally have r: "Mp R = Mp (T * U - D * Q)" by simp
  have "Mp (A * D + B * H) = Mp (Mp (A * D) + Mp (B * H))" by simp
  also have "Mp (A * D) = Mp ((S * U + H * Q) * D)" unfolding A by simp
  also have "Mp (B * H) = Mp (Mp R * Mp H)" unfolding B by simp
  also have " = Mp ((T * U - D * Q) * H)" unfolding r by simp
  also have "Mp (Mp ((S * U + H * Q) * D) + Mp ((T * U - D * Q) * H)) = 
    Mp ((S * U + H * Q) * D + (T * U - D * Q) * H)" by simp
  also have "(S * U + H * Q) * D + (T * U - D * Q) * H = (D * S + H * T) * U"
    by (simp add: field_simps)
  also have "Mp  = Mp (Mp (D * S + H * T) * U)" by simp
  also have "Mp (D * S + H * T) = 1" using 1 by simp
  finally show eq: "A * D + B * H =m U" by simp
  have id: "degree_m (Mp R) = degree_m R" by simp
  have id': "degree D = degree_m D" using mon by simp
  show degB: "B = 0  degree B < degree D" using deg unfolding B id id'
    using degree_m_le[of R] by (cases "R = 0", auto)
  show Mp: "Mp A = A" "Mp B = B" unfolding A B by auto
  assume another: "A' * D + B' * H =m U" and degB': "B' = 0  degree B' < degree D" 
    and norm: "Mp A' = A'" "Mp B' = B'" and cop: "coprime_m D H" and D: "Mp D = D" 
    and prime: "prime m"
  from degB Mp D have degB: "B =m 0  degree_m B < degree_m D" by auto
  from degB' Mp D norm have degB': "B' =m 0  degree_m B' < degree_m D" by auto
  from mon D have D0: "¬ (D =m 0)" by auto
  from prime interpret poly_mod_prime m by unfold_locales
  from another eq have "A' * D + B' * H =m A * D + B * H" by simp
  from uniqueness_poly_equality[OF cop degB' degB D0 this]
  show "A' = A  B' = B" unfolding norm Mp by auto
qed


lemma coprime_bezout_coefficients:
  assumes cop: "coprime f g"
    and ext: "bezout_coefficients f g = (a, b)" 
  shows "a * f + b * g = 1"
  using assms bezout_coefficients [of f g a b]
  by simp

lemma (in poly_mod_prime_type) bezout_coefficients_mod_int: assumes f: "(F :: 'a mod_ring poly) = of_int_poly f"
  and g: "(G :: 'a mod_ring poly) = of_int_poly g" 
  and cop: "coprime_m f g" 
  and fact: "bezout_coefficients F G = (A,B)" 
  and a: "a = to_int_poly A"
  and b: "b = to_int_poly B"
  shows "f * a + g * b =m 1"
proof -
  have f[transfer_rule]: "MP_Rel f F" unfolding f MP_Rel_def by (simp add: Mp_f_representative)
  have g[transfer_rule]: "MP_Rel g G" unfolding g MP_Rel_def by (simp add: Mp_f_representative)
  have [transfer_rule]: "MP_Rel a A" unfolding a MP_Rel_def by (rule Mp_to_int_poly)
  have [transfer_rule]: "MP_Rel b B" unfolding b MP_Rel_def by (rule Mp_to_int_poly)
  from cop have "coprime F G" using coprime_MP_Rel[unfolded rel_fun_def] f g by auto
  from coprime_bezout_coefficients [OF this fact]
  have "A * F + B * G = 1" .
  from this [untransferred]
  show ?thesis by (simp add: ac_simps)
qed
  
definition bezout_coefficients_i :: "'i arith_ops_record  'i list  'i list  'i list × 'i list" where
  "bezout_coefficients_i ff_ops f g = fst (euclid_ext_poly_i ff_ops f g)"

definition euclid_ext_poly_mod_main :: "int  'a arith_ops_record  int poly  int poly  int poly × int poly" where
  "euclid_ext_poly_mod_main p ff_ops f g = (case bezout_coefficients_i ff_ops (of_int_poly_i ff_ops f) (of_int_poly_i ff_ops g) of 
      (a,b)  (to_int_poly_i ff_ops a, to_int_poly_i ff_ops b))" 

definition euclid_ext_poly_dynamic :: "int  int poly  int poly  int poly × int poly" where
  "euclid_ext_poly_dynamic p = ( 
    if p  65535 
    then euclid_ext_poly_mod_main p (finite_field_ops32 (uint32_of_int p))
    else if p  4294967295
    then euclid_ext_poly_mod_main p (finite_field_ops64 (uint64_of_int p))
    else euclid_ext_poly_mod_main p (finite_field_ops_integer (integer_of_int p)))" 
  
context prime_field_gen
begin
lemma bezout_coefficients_i[transfer_rule]: 
  "(poly_rel ===> poly_rel ===> rel_prod poly_rel poly_rel)
     (bezout_coefficients_i ff_ops) bezout_coefficients"
  unfolding bezout_coefficients_i_def bezout_coefficients_def
  by transfer_prover

lemma bezout_coefficients_i_sound: assumes f: "f' = of_int_poly_i ff_ops f" "Mp f = f"
  and g: "g' = of_int_poly_i ff_ops g" "Mp g = g"  
  and cop: "coprime_m f g" 
  and res: "bezout_coefficients_i ff_ops f' g' = (a',b')" 
  and a: "a = to_int_poly_i ff_ops a'"
  and b: "b = to_int_poly_i ff_ops b'"
shows "f * a + g * b =m 1"
  "Mp a = a" "Mp b = b" 
proof -
  from f have f': "f' = of_int_poly_i ff_ops (Mp f)" by simp
  define f'' where "f''  of_int_poly (Mp f) :: 'a mod_ring poly"
  have f'': "f'' = of_int_poly f" unfolding f''_def f by simp
  have rel_f[transfer_rule]: "poly_rel f' f''" 
    by (rule poly_rel_of_int_poly[OF f'], simp add: f'' f)
  from g have g': "g' = of_int_poly_i ff_ops (Mp g)" by simp
  define g'' where "g''  of_int_poly (Mp g) :: 'a mod_ring poly"
  have g'': "g'' = of_int_poly g" unfolding g''_def g by simp
  have rel_g[transfer_rule]: "poly_rel g' g''"     
    by (rule poly_rel_of_int_poly[OF g'], simp add: g'' g)
  obtain a'' b'' where eucl: "bezout_coefficients f'' g'' = (a'',b'')" by force
  from bezout_coefficients_i[unfolded rel_fun_def rel_prod_conv, rule_format, OF rel_f rel_g,
    unfolded res split eucl]
  have rel[transfer_rule]: "poly_rel a' a''" "poly_rel b' b''" by auto
  with to_int_poly_i have a: "a = to_int_poly a''" 
    and b: "b = to_int_poly b''" unfolding a b by auto
  from bezout_coefficients_mod_int [OF f'' g'' cop eucl a b]
  show "f * a + g * b =m 1" .
  show "Mp a = a" "Mp b = b" unfolding a b by (auto simp: Mp_to_int_poly)
qed

lemma euclid_ext_poly_mod_main: assumes cop: "coprime_m f g" 
  and f: "Mp f = f" and g: "Mp g = g" 
  and res: "euclid_ext_poly_mod_main m ff_ops f g = (a,b)" 
shows "f * a + g * b =m 1" 
  "Mp a = a" "Mp b = b" 
proof -
  obtain a' b' where res': "bezout_coefficients_i ff_ops (of_int_poly_i ff_ops f) 
    (of_int_poly_i ff_ops g) = (a', b')" by force
  show "f * a + g * b =m 1" 
  "Mp a = a" "Mp b = b"
    by (insert bezout_coefficients_i_sound[OF refl f refl g cop res']
    res [unfolded euclid_ext_poly_mod_main_def res'], auto)
qed

end

context poly_mod_prime begin

lemmas euclid_ext_poly_mod_integer = prime_field_gen.euclid_ext_poly_mod_main
  [OF prime_field.prime_field_finite_field_ops_integer,
  unfolded prime_field_def mod_ring_locale_def poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas euclid_ext_poly_mod_uint32 = prime_field_gen.euclid_ext_poly_mod_main
  [OF prime_field.prime_field_finite_field_ops32,
  unfolded prime_field_def mod_ring_locale_def poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas euclid_ext_poly_mod_uint64 = prime_field_gen.euclid_ext_poly_mod_main[OF prime_field.prime_field_finite_field_ops64,
  unfolded prime_field_def mod_ring_locale_def poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma euclid_ext_poly_dynamic:
  assumes cop: "coprime_m f g" and f: "Mp f = f" and g: "Mp g = g"
    and res: "euclid_ext_poly_dynamic p f g = (a,b)" 
  shows "f * a + g * b =m 1" 
    "Mp a = a" "Mp b = b"
  using euclid_ext_poly_mod_integer[OF cop f g, of p a b]
    euclid_ext_poly_mod_uint32[OF _ cop f g, of p a b]
    euclid_ext_poly_mod_uint64[OF _ cop f g, of p a b]
    res[unfolded euclid_ext_poly_dynamic_def] by (auto split: if_splits)

end

lemma range_sum_prod: assumes xy: "x  {0..<q}" "(y :: int)  {0..<p}" 
  shows "x + q * y  {0..<p * q}"
proof -
  {
    fix x q :: int
    have "x  {0 ..< q}  0  x  x < q" by auto
  } note id = this
  from xy have 0: "0  x + q * y" by auto
  have "x + q * y  q - 1 + q * y" using xy by simp
  also have "q * y  q * (p - 1)" using xy by auto
  finally have "x + q * y  q - 1 + q * (p - 1)" by auto
  also have " = p * q - 1" by (simp add: field_simps)
  finally show ?thesis using 0 by auto
qed

context 
  fixes C :: "int poly" 
begin

context
  fixes p :: int and S T D1 H1 :: "int poly" 
begin
(* The linear lifting is implemented for ease of provability.
   Aim: show uniqueness of factorization *)
fun linear_hensel_main where 
  "linear_hensel_main (Suc 0) = (D1,H1)" 
| "linear_hensel_main (Suc n) = (
      let (D,H) = linear_hensel_main n;
        q = p ^ n;
        U = poly_mod.Mp p (sdiv_poly (C - D * H) q);   ― ‹H2 + H3›
        (A,B) = poly_mod.dupe_monic_int p D1 H1 S T U
      in (D + smult q B, H + smult q A)) ― ‹H4›"
    | "linear_hensel_main 0 = (D1,H1)" 

lemma linear_hensel_main: assumes 1: "poly_mod.eq_m p (D1 * S + H1 * T) 1" 
  and equiv: "poly_mod.eq_m p (D1 * H1) C"
  and monD1: "monic D1" 
  and normDH1: "poly_mod.Mp p D1 = D1" "poly_mod.Mp p H1 = H1"
  and res: "linear_hensel_main n = (D,H)" 
  and n: "n  0" 
  and prime: "prime p" ― ‹p > 1› suffices if one does not need uniqueness›
  and cop: "poly_mod.coprime_m p D1 H1"
  shows "poly_mod.eq_m (p^n) (D * H) C
     monic D
     poly_mod.eq_m p D D1  poly_mod.eq_m p H H1
     poly_mod.Mp (p^n) D = D
     poly_mod.Mp (p^n) H = H  
    (poly_mod.eq_m (p^n) (D' * H') C 
     poly_mod.eq_m p D' D1  
     poly_mod.eq_m p H' H1 
     poly_mod.Mp (p^n) D' = D' 
     poly_mod.Mp (p^n) H' = H'  monic D'  D' = D  H' = H)
     " 
  using res n 
proof (induct n arbitrary: D H D' H')
  case (Suc n D' H' D'' H'')
  show ?case
  proof (cases "n = 0")
    case True
    with Suc equiv monD1 normDH1 show ?thesis by auto
  next
    case False
    hence n: "n  0" by auto
    let ?q = "p^n"
    let ?pq = "p * p^n"
    from prime have p: "p > 1" using prime_gt_1_int by force
    from n p have q: "?q > 1" by auto
    from n p have pq: "?pq > 1" by (metis power_gt1_lemma)
    interpret p: poly_mod_2 p using p unfolding poly_mod_2_def .
    interpret q: poly_mod_2 ?q using q unfolding poly_mod_2_def .
    interpret pq: poly_mod_2 ?pq using pq unfolding poly_mod_2_def .
    obtain D H where rec: "linear_hensel_main n = (D,H)" by force
    obtain V where V: "sdiv_poly (C - D * H) ?q = V" by force
    obtain U where U: "p.Mp (sdiv_poly (C - D * H) ?q) = U" by auto
    obtain A B where dupe: "p.dupe_monic_int D1 H1 S T U = (A,B)" by force
    note IH = Suc(1)[OF rec n]
    from IH
    have CDH: "q.eq_m (D * H) C"
      and monD: "monic D"
      and p_eq: "p.eq_m D D1" "p.eq_m H H1"
      and norm: "q.Mp D = D" "q.Mp H = H" by auto
    from n obtain k where n: "n = Suc k" by (cases n, auto)
    have qq: "?q * ?q = ?pq * p^k" unfolding n by simp
    from Suc(2)[unfolded n linear_hensel_main.simps, folded n, unfolded rec split Let_def U dupe]
    have D': "D' = D + smult ?q B" and H': "H' = H + smult ?q A" by auto
    note dupe = p.dupe_monic_int[OF 1 monD1 dupe]
    from CDH have "q.Mp C - q.Mp (D * H) = 0" by simp
    hence "q.Mp (q.Mp C - q.Mp (D * H)) = 0" by simp
    hence "q.Mp (C - D*H) = 0" by simp
    from q.Mp_0_smult_sdiv_poly[OF this] have CDHq: "smult ?q (sdiv_poly (C - D * H) ?q) = C - D * H" .
    have ADBHU: "p.eq_m (A * D + B * H) U" using p_eq dupe(1) 
      by (metis (mono_tags, lifting) p.mult_Mp(2) poly_mod.plus_Mp)
    have "pq.Mp (D' * H') = pq.Mp ((D + smult ?q B) * (H + smult ?q A))" 
      unfolding D' H' by simp
    also have "(D + smult ?q B) * (H + smult ?q A) = (D * H + smult ?q (A * D + B * H)) + smult (?q * ?q) (A * B)" 
      by (simp add: field_simps smult_distribs)
    also have "pq.Mp  = pq.Mp (D * H + pq.Mp (smult ?q (A * D + B * H)) + pq.Mp (smult (?q * ?q) (A * B)))"
      using pq.plus_Mp by metis
    also have "pq.Mp (smult (?q * ?q) (A * B)) = 0" unfolding qq
      by (metis pq.Mp_smult_m_0 smult_smult)
    finally have DH': "pq.Mp (D' * H') = pq.Mp (D * H + pq.Mp (smult ?q (A * D + B * H)))" by simp
    also have "pq.Mp (smult ?q (A * D + B * H)) = pq.Mp (smult ?q U)"
      using p.Mp_lift_modulus[OF ADBHU, of ?q] by simp
    also have " = pq.Mp (C - D * H)" 
      unfolding arg_cong[OF CDHq, of pq.Mp, symmetric] U[symmetric] V
      by (rule p.Mp_lift_modulus[of _ _ ?q], auto) 
    also have "pq.Mp (D * H + pq.Mp (C - D * H)) = pq.Mp C" by simp
    finally have CDH: "pq.eq_m C (D' * H')" by simp

    have deg: "degree D1 = degree D" using p_eq(1) monD1 monD
      by (metis p.monic_degree_m)
    have mon: "monic D'" unfolding D' using dupe(2) monD unfolding deg by (rule monic_smult_add_small)
    have normD': "pq.Mp D' = D'" 
      unfolding D' pq.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq coeff_smult 
    proof 
      fix i
      from norm(1) dupe(4) have "coeff D i  {0..<?q}" "coeff B i  {0..<p}" 
        unfolding p.Mp_ident_iff q.Mp_ident_iff by auto
      thus "coeff D i + ?q * coeff B i  {0..< ?pq}" by (rule range_sum_prod)
    qed
    have normH': "pq.Mp H' = H'" 
      unfolding H' pq.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq coeff_smult 
    proof 
      fix i
      from norm(2) dupe(3) have "coeff H i  {0..<?q}" "coeff A i  {0..<p}" 
        unfolding p.Mp_ident_iff q.Mp_ident_iff by auto
      thus "coeff H i + ?q * coeff A i  {0..< ?pq}" by (rule range_sum_prod)
    qed
    have eq: "p.eq_m D D'" "p.eq_m H H'" unfolding D' H' n 
        poly_eq_iff p.Mp_coeff p.M_def by (auto simp: field_simps)
    with p_eq have eq: "p.eq_m D' D1" "p.eq_m H' H1" by auto
    {
      assume CDH'': "pq.eq_m C (D'' * H'')" 
        and DH1'': "p.eq_m D1 D''" "p.eq_m H1 H''"
        and norm'': "pq.Mp D'' = D''" "pq.Mp H'' = H''" 
        and monD'': "monic D''" 
      from q.Dp_Mp_eq[of D''] obtain d B' where D'': "D'' = q.Mp d + smult ?q B'" by auto
      from q.Dp_Mp_eq[of H''] obtain h A' where H'': "H'' = q.Mp h + smult ?q A'" by auto
      {
        fix A B
        assume *: "pq.Mp (q.Mp A + smult ?q B) = q.Mp A + smult ?q B" 
        have "p.Mp B = B" unfolding p.Mp_ident_iff
        proof 
          fix i
          from arg_cong[OF *, of "λ f. coeff f i", unfolded pq.Mp_coeff pq.M_def]
          have "coeff (q.Mp A + smult ?q B) i  {0 ..< ?pq}" using "*" pq.Mp_ident_iff by blast 
          hence sum: "coeff (q.Mp A) i + ?q * coeff B i  {0 ..< ?pq}" by auto
          have "q.Mp (q.Mp A) = q.Mp A" by auto
          from this[unfolded q.Mp_ident_iff] have A: "coeff (q.Mp A) i  {0 ..< p^n}" by auto
          {
            assume "coeff B i < 0" hence "coeff B i  -1" by auto
            from mult_left_mono[OF this, of ?q] q.m1 have "?q * coeff B i  -?q" by simp
            with A sum have False by auto
          } hence "coeff B i  0" by force
          moreover
          {
            assume "coeff B i  p" 
            from mult_left_mono[OF this, of ?q] q.m1 have "?q * coeff B i  ?pq" by simp
            with A sum have False by auto
          } hence "coeff B i < p" by force
          ultimately show "coeff B i  {0 ..< p}" by auto
        qed
      } note norm_convert = this
      from norm_convert[OF norm''(1)[unfolded D'']] have normB': "p.Mp B' = B'" . 
      from norm_convert[OF norm''(2)[unfolded H'']] have normA': "p.Mp A' = A'" . 
      let ?d = "q.Mp d" 
      let ?h = "q.Mp h"
      {
        assume lt: "degree ?d < degree B'"
        hence eq: "degree D'' = degree B'" unfolding D'' using q.m1 p.m1
          by (subst degree_add_eq_right, auto)
        from lt have [simp]: "coeff ?d (degree B') = 0" by (rule coeff_eq_0)
        from monD''[unfolded eq, unfolded D'', simplified] False q.m1 lt have False
          by (metis mod_mult_self1_is_0 poly_mod.M_def q.M_1 zero_neq_one)
      }
      hence deg_dB': "degree ?d  degree B'" by presburger
      {
        assume eq: "degree ?d = degree B'" and B': "B'  0"  
        let ?B = "coeff B' (degree B')" 
        from normB'[unfolded p.Mp_ident_iff, rule_format, of "degree B'"] B'
        have "?B  {0..<p} - {0}" by simp
        hence bnds: "?B > 0" "?B < p" by auto
        have degD'': "degree D''  degree ?d" unfolding D'' using eq by (simp add: degree_add_le)
        have "?q * ?B  1 * 1" by (rule mult_mono, insert q.m1 bnds, auto) 
        moreover have "coeff D'' (degree ?d) = 1 + ?q * ?B" using monD''
          unfolding D'' using eq 
          by (metis D'' coeff_smult monD'' plus_poly.rep_eq poly_mod.Dp_Mp_eq 
              poly_mod.degree_m_eq_monic poly_mod.plus_Mp(1) 
              q.Mp_smult_m_0 q.m1 q.monic_Mp q.plus_Mp(2))
        ultimately have gt: "coeff D'' (degree ?d) > 1" by auto
        hence "coeff D'' (degree ?d)  0" by auto
        hence "degree D''  degree ?d" by (rule le_degree)
        with degree_add_le_max[of ?d "smult ?q B'", folded D''] eq 
        have deg: "degree D'' = degree ?d" using degD'' by linarith
        from gt[folded this] have "¬ monic D''" by auto
        with monD'' have False by auto
      }
      with deg_dB' have deg_dB2: "B' = 0  degree B' < degree ?d" by fastforce
      have d: "q.Mp D'' = ?d" unfolding D''
        by (metis add.right_neutral poly_mod.Mp_smult_m_0 poly_mod.plus_Mp)
      have h: "q.Mp H'' = ?h" unfolding H''
        by (metis add.right_neutral poly_mod.Mp_smult_m_0 poly_mod.plus_Mp)
      from CDH'' have "pq.Mp C = pq.Mp (D'' * H'')" by simp
      from arg_cong[OF this, of q.Mp] 
      have "q.Mp C = q.Mp (D'' * H'')"
        using p.m1 q.Mp_product_modulus by auto
      also have " = q.Mp (q.Mp D'' * q.Mp H'')" by simp
      also have " = q.Mp (?d * ?h)" unfolding d h by simp
      finally have eqC: "q.eq_m (?d * ?h) C" by auto
      have d1: "p.eq_m ?d D1" unfolding d[symmetric] using DH1''
        using assms(4) n p.Mp_product_modulus p.m1 by auto
      have h1: "p.eq_m ?h H1" unfolding h[symmetric] using DH1''
        using assms(5) n p.Mp_product_modulus p.m1 by auto
      have mond: "monic (q.Mp d)" using monD'' deg_dB2 unfolding D''
        using d q.monic_Mp[OF monD''] by simp
      from eqC d1 h1 mond IH[of "q.Mp d" "q.Mp h"] have IH: "?d = D" "?h = H" by auto
      from deg_dB2[unfolded IH] have degB': "B' = 0  degree B' < degree D" by auto
      from IH have D'': "D'' = D + smult ?q B'" and H'': "H'' = H + smult ?q A'" 
        unfolding D'' H'' by auto
      have "pq.Mp (D'' * H'') = pq.Mp (D' * H')" using CDH'' CDH  by simp
      also have "pq.Mp (D'' * H'') = pq.Mp ((D + smult ?q B') * (H + smult ?q A'))" 
        unfolding D'' H'' by simp
      also have "(D + smult ?q B') * (H + smult ?q A') = (D * H + smult ?q (A' * D + B' * H)) + smult (?q * ?q) (A' * B')" 
        by (simp add: field_simps smult_distribs)
      also have "pq.Mp  = pq.Mp (D * H + pq.Mp (smult ?q (A' * D + B' * H)) + pq.Mp (smult (?q * ?q) (A' * B')))"
        using pq.plus_Mp by metis
      also have "pq.Mp (smult (?q * ?q) (A' * B')) = 0" unfolding qq
        by (metis pq.Mp_smult_m_0 smult_smult)
      finally have "pq.Mp (D * H + pq.Mp (smult ?q (A' * D + B' * H))) 
        = pq.Mp (D * H + pq.Mp (smult ?q (A * D + B * H)))" unfolding DH' by simp
      hence "pq.Mp (smult ?q (A' * D + B' * H)) = pq.Mp (smult ?q (A * D + B * H))"
        by (metis (no_types, lifting) add_diff_cancel_left' poly_mod.minus_Mp(1) poly_mod.plus_Mp(2))
      hence "p.Mp (A' * D + B' * H) = p.Mp (A * D + B * H)" unfolding poly_eq_iff p.Mp_coeff pq.Mp_coeff coeff_smult
        by (insert p, auto simp: p.M_def pq.M_def)
      hence "p.Mp (A' * D1 + B' * H1) = p.Mp (A * D1 + B * H1)" using p_eq
        by (metis p.mult_Mp(2) poly_mod.plus_Mp)
      hence eq: "p.eq_m (A' * D1 + B' * H1) U" using dupe(1) by auto
      have "degree D = degree D1" using monD monD1 
          arg_cong[OF p_eq(1), of degree] 
          p.degree_m_eq_monic[OF _ p.m1] by auto
      hence "B' = 0  degree B' < degree D1" using degB' by simp
      from dupe(5)[OF cop eq this normDH1(1) normA' normB' prime] have "A' = A" "B' = B" by auto
      hence "D'' = D'" "H'' = H'" unfolding D'' H'' D' H' by auto
    }
    thus ?thesis using normD' normH' CDH mon eq by simp
  qed
qed simp
end
end

definition linear_hensel_binary :: "int  nat  int poly  int poly  int poly  int poly × int poly" where
  "linear_hensel_binary p n C D H = (let
     (S,T) = euclid_ext_poly_dynamic p D H
     in linear_hensel_main C p S T D H n)"

lemma (in poly_mod_prime) unique_hensel_binary: 
  assumes prime: "prime p"
  and cop: "coprime_m D H" and eq: "eq_m (D * H) C"
  and normalized_input: "Mp D = D" "Mp H = H"
  and monic_input: "monic D" 
  and n: "n  0" 
shows "∃! (D',H'). ― ‹D'›, H'› are computed via linear_hensel_binary›
      poly_mod.eq_m (p^n) (D' * H') C ― ‹the main result: equivalence mod p^n›
     monic D' ― ‹monic output›
     eq_m D D'  eq_m H H' ― ‹apply `mod p`› on D'› and H'› yields D› and H› again›
     poly_mod.Mp (p^n) D' = D'  poly_mod.Mp (p^n) H' = H' ― ‹output is normalized›"
proof -
  obtain D' H' where hensel_result: "linear_hensel_binary p n C D H = (D',H')" by force
  from m1 have p: "p > 1" .
  obtain S T where ext: "euclid_ext_poly_dynamic p D H = (S,T)" by force
  obtain D1 H1 where main: "linear_hensel_main C p S T D H n = (D1,H1)" by force
  from hensel_result[unfolded linear_hensel_binary_def ext split Let_def main]
  have id: "D1 = D'" "H1 = H'" by auto
  note eucl = euclid_ext_poly_dynamic [OF cop normalized_input ext]
  from linear_hensel_main [OF eucl(1)
    eq monic_input normalized_input main [unfolded id] n prime cop]
  show ?thesis by (intro ex1I, auto)
qed

(* The quadratic lifting is implemented more efficienty.
   Aim: compute factorization *)
context
  fixes C :: "int poly"
begin

lemma hensel_step_main: assumes 
      one_q: "poly_mod.eq_m q (D * S + H * T) 1"
  and one_p: "poly_mod.eq_m p (D1 * S1 + H1 * T1) 1"
  and CDHq: "poly_mod.eq_m q C (D * H)"
  and D1D: "poly_mod.eq_m p D1 D" 
  and H1H: "poly_mod.eq_m p H1 H" 
  and S1S: "poly_mod.eq_m p S1 S" 
  and T1T: "poly_mod.eq_m p T1 T" 
  and mon: "monic D" 
  and mon1: "monic D1" 
  and q: "q > 1" 
  and p: "p > 1" 
  and D1: "poly_mod.Mp p D1 = D1" 
  and H1: "poly_mod.Mp p H1 = H1"
  and S1: "poly_mod.Mp p S1 = S1" 
  and T1: "poly_mod.Mp p T1 = T1"
  and D: "poly_mod.Mp q D = D" 
  and H: "poly_mod.Mp q H = H"
  and S: "poly_mod.Mp q S = S" 
  and T: "poly_mod.Mp q T = T"
  and U1: "U1 = poly_mod.Mp p (sdiv_poly (C - D * H) q)"
  and dupe1: "dupe_monic_dynamic p D1 H1 S1 T1 U1 = (A,B)" 
  and D': "D' = D + smult q B"
  and H': "H' = H + smult q A" 
  and U2: "U2 = poly_mod.Mp q (sdiv_poly (S*D' + T*H' - 1) p)" 
  and dupe2: "dupe_monic_dynamic q D H S T U2 = (A',B')" 
  and rq: "r = p * q" 
  and pq: "p dvd q"  
  and S': "S' = poly_mod.Mp r (S - smult p A')"
  and T': "T' = poly_mod.Mp r (T - smult p B')" 
shows "poly_mod.eq_m r C (D' * H')" 
  "poly_mod.Mp r D' = D'" 
  "poly_mod.Mp r H' = H'" 
  "poly_mod.Mp r S' = S'" 
  "poly_mod.Mp r T' = T'" 
  "poly_mod.eq_m r (D' * S' + H' * T') 1" 
  "monic D'" 
  unfolding rq
proof -
  from pq obtain k where qp: "q = p * k" unfolding dvd_def by auto
  from arg_cong[OF qp, of sgn] q p have k0: "k > 0" unfolding sgn_mult by (auto simp: sgn_1_pos)
  from qp have qq: "q * q = p * q * k" by auto
  let ?r = "p * q" 
  interpret poly_mod_2 p by (standard, insert p, auto)
  interpret q: poly_mod_2 q by (standard, insert q, auto)
  from p q have r: "?r > 1" by (simp add: less_1_mult)
  interpret r: poly_mod_2 ?r using r unfolding poly_mod_2_def .  
  have Mp_conv: "Mp (q.Mp x) = Mp x" for x unfolding qp
    by (rule Mp_product_modulus[OF refl k0])
  from arg_cong[OF CDHq, of Mp, unfolded Mp_conv] have "Mp C = Mp (Mp D * Mp H)"
    by simp
  also have "Mp D = Mp D1" using D1D by simp
  also have "Mp H = Mp H1" using H1H by simp
  finally have CDHp: "eq_m C (D1 * H1)" by simp
  have "Mp U1 = U1" unfolding U1 by simp
  note dupe1 = dupe_monic_dynamic[OF dupe1 one_p mon1 D1 H1 S1 T1 this]
  have "q.Mp U2 = U2" unfolding U2 by simp
  note dupe2 = q.dupe_monic_dynamic[OF dupe2 one_q mon D H S T this]
  from CDHq have "q.Mp C - q.Mp (D * H) = 0" by simp
  hence "q.Mp (q.Mp C - q.Mp (D * H)) = 0" by simp
  hence "q.Mp (C - D*H) = 0" by simp
  from q.Mp_0_smult_sdiv_poly[OF this] have CDHq: "smult q (sdiv_poly (C - D * H) q) = C - D * H" .
  {
    fix A B
    have "Mp (A * D1 + B * H1) = Mp (Mp (A * D1) + Mp (B * H1))" by simp
    also have "Mp (A * D1) = Mp (A * Mp D1)" by simp
    also have " = Mp (A * D)" unfolding D1D by simp
    also have "Mp (B * H1) = Mp (B * Mp H1)" by simp
    also have " = Mp (B * H)" unfolding H1H by simp
    finally have "Mp (A * D1 + B * H1) = Mp (A * D + B * H)" by simp
  } note D1H1 = this
  have "r.Mp (D' * H') = r.Mp ((D + smult q B) * (H + smult q A))" 
    unfolding D' H' by simp
  also have "(D + smult q B) * (H + smult q A) = (D * H + smult q (A * D + B * H)) + smult (q * q) (A * B)" 
    by (simp add: field_simps smult_distribs)
  also have "r.Mp  = r.Mp (D * H + r.Mp (smult q (A * D + B * H)) + r.Mp (smult (q * q) (A * B)))"
    using r.plus_Mp by metis
  also have "r.Mp (smult (q * q) (A * B)) = 0" unfolding qq
    by (metis r.Mp_smult_m_0 smult_smult)
  also have "r.Mp (smult q (A * D + B * H)) = r.Mp (smult q U1)" 
  proof (rule Mp_lift_modulus[of _ _ q])
    show "Mp (A * D + B * H) = Mp U1" using dupe1(1) unfolding D1H1 by simp
  qed
  also have " = r.Mp (C - D * H)" 
    unfolding arg_cong[OF CDHq, of r.Mp, symmetric]
    using Mp_lift_modulus[of U1 "sdiv_poly (C - D * H) q" q] unfolding U1 
    by simp
  also have "r.Mp (D * H + r.Mp (C - D * H) + 0) = r.Mp C" by simp
  finally show CDH: "r.eq_m C (D' * H')" by simp
  have "degree D1 = degree (Mp D1)" using mon1 by simp
  also have " = degree D" unfolding D1D using mon by simp
  finally have deg_eq: "degree D1 = degree D" by simp
  show mon: "monic D'" unfolding D' using dupe1(2) mon unfolding deg_eq by (rule monic_smult_add_small)
  have "Mp (S * D' + T * H' - 1) = Mp (Mp (D * S + H * T) + (smult q (S * B + T * A) - 1))" 
    unfolding D' H' plus_Mp by (simp add: field_simps smult_distribs)
  also have "Mp (D * S + H * T) = Mp (Mp (D1 * Mp S) + Mp (H1 * Mp T))" using  D1H1[of S T] by (simp add: ac_simps)
  also have " = 1" using one_p unfolding S1S[symmetric] T1T[symmetric] by simp
  also have "Mp (1 + (smult q (S * B + T * A) - 1)) = Mp (smult q (S * B + T * A))" by simp
  also have " = 0" unfolding qp by (metis Mp_smult_m_0 smult_smult)
  finally have "Mp (S * D' + T * H' - 1) = 0" .
  from Mp_0_smult_sdiv_poly[OF this] 
  have SDTH: "smult p (sdiv_poly (S * D' + T * H' - 1) p) = S * D' + T * H' - 1" .
  have swap: "q * p = p * q" by simp
  have "r.Mp (D' * S' + H' * T') = 
    r.Mp ((D + smult q B) * (S - smult p A') + (H + smult q A) * (T - smult p B'))"
    unfolding D' S' H' T' rq using r.plus_Mp r.mult_Mp by metis
  also have " = r.Mp ((D * S + H * T +
    smult q (B * S + A * T)) - smult p (A' * D + B' * H) - smult ?r (A * B' + B * A'))" 
    by (simp add: field_simps smult_distribs)
  also have " = r.Mp ((D * S + H * T +
    smult q (B * S + A * T)) - r.Mp (smult p (A' * D + B' * H)) - r.Mp (smult ?r (A * B' + B * A')))"
    using r.plus_Mp r.minus_Mp by metis
  also have "r.Mp (smult ?r (A * B' + B * A')) = 0" by simp
  also have "r.Mp (smult p (A' * D + B' * H)) = r.Mp (smult p U2)" 
    using q.Mp_lift_modulus[OF dupe2(1), of p] unfolding swap .
  also have " = r.Mp (S * D' + T * H' - 1)" 
    unfolding arg_cong[OF SDTH, of r.Mp, symmetric] 
    using q.Mp_lift_modulus[of U2 "sdiv_poly (S * D' + T * H' - 1) p" p] 
    unfolding U2 swap by simp
  also have "S * D' + T * H' - 1 = S * D + T * H + smult q (B * S + A * T) - 1" 
    unfolding D' H' by (simp add: field_simps smult_distribs)
  also have "r.Mp (D * S + H * T + smult q (B * S + A * T) -
     r.Mp (S * D + T * H + smult q (B * S + A * T) - 1) - 0) 
       = 1" by simp
  finally show 1: "r.eq_m (D' * S' + H' * T') 1" by simp
  show D': "r.Mp D' = D'" unfolding D' r.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq
    coeff_smult 
  proof 
    fix n
    from D dupe1(4) have "coeff D n  {0..<q}" "coeff B n  {0..<p}" 
      unfolding q.Mp_ident_iff Mp_ident_iff by auto
    thus "coeff D n + q * coeff B n  {0..<?r}" by (metis range_sum_prod)
  qed
  show H': "r.Mp H' = H'" unfolding H' r.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq
    coeff_smult 
  proof 
    fix n
    from H dupe1(3) have "coeff H n  {0..<q}" "coeff A n  {0..<p}" 
      unfolding q.Mp_ident_iff Mp_ident_iff by auto
    thus "coeff H n + q * coeff A n  {0..<?r}" by (metis range_sum_prod)
  qed
  show "poly_mod.Mp ?r S' = S'" "poly_mod.Mp ?r T' = T'" 
    unfolding S' T' rq by auto
qed

definition hensel_step where 
  "hensel_step p q S1 T1 D1 H1 S T D H = (
      let U = poly_mod.Mp p (sdiv_poly (C - D * H) q); ― ‹Z2 and Z3›        
        (A,B) = dupe_monic_dynamic p D1 H1 S1 T1 U;
        D' = D + smult q B; ― ‹Z4›
        H' = H + smult q A;
        U' = poly_mod.Mp q (sdiv_poly (S*D' + T*H' - 1) p); ― ‹Z5 + Z6›
        (A',B') = dupe_monic_dynamic q D H S T U';
        q' = p * q;
        S' = poly_mod.Mp q' (S - smult p A'); ― ‹Z7›
        T' = poly_mod.Mp q' (T - smult p B')
     in (S',T',D',H'))" 

definition "quadratic_hensel_step q S T D H = hensel_step q q S T D H S T D H" 

lemma quadratic_hensel_step_code[code]:
  "quadratic_hensel_step q S T D H =
    (let dupe = dupe_monic_dynamic q D H S T; ― ‹this will share the conversions of D H S T›
         U = poly_mod.Mp q (sdiv_poly (C - D * H) q); 
         (A, B) = dupe U; 
         D' = D + Polynomial.smult q B;
         H' = H + Polynomial.smult q A; 
         U' = poly_mod.Mp q (sdiv_poly (S * D' + T * H' - 1) q); 
         (A', B') = dupe U';
         q' = q * q; 
         S' = poly_mod.Mp q' (S - Polynomial.smult q A'); 
         T' = poly_mod.Mp q' (T - Polynomial.smult q B')
           in (S', T', D', H'))" 
  unfolding quadratic_hensel_step_def[unfolded hensel_step_def] Let_def ..

definition simple_quadratic_hensel_step where ― ‹do not compute new values S'› and T'›
  "simple_quadratic_hensel_step q S T D H = (
      let U = poly_mod.Mp q (sdiv_poly (C - D * H) q); ― ‹Z2 + Z3›
        (A,B) = dupe_monic_dynamic q D H S T U;
        D' = D + smult q B; ― ‹Z4›
        H' = H + smult q A
     in (D',H'))" 

lemma hensel_step: assumes step: "hensel_step p q S1 T1 D1 H1 S T D H = (S', T', D', H')"
  and one_p: "poly_mod.eq_m p (D1 * S1 + H1 * T1) 1"
  and mon1: "monic D1" 
  and p: "p > 1" 
  and CDHq: "poly_mod.eq_m q C (D * H)"
  and one_q: "poly_mod.eq_m q (D * S + H * T) 1"
  and D1D: "poly_mod.eq_m p D1 D"
  and H1H: "poly_mod.eq_m p H1 H"
  and S1S: "poly_mod.eq_m p S1 S"
  and T1T: "poly_mod.eq_m p T1 T"
  and mon: "monic D" 
  and q: "q > 1" 
  and D1: "poly_mod.Mp p D1 = D1" 
  and H1: "poly_mod.Mp p H1 = H1"
  and S1: "poly_mod.Mp p S1 = S1" 
  and T1: "poly_mod.Mp p T1 = T1"
  and D: "poly_mod.Mp q D = D" 
  and H: "poly_mod.Mp q H = H"
  and S: "poly_mod.Mp q S = S" 
  and T: "poly_mod.Mp q T = T"
  and rq: "r = p * q" 
  and pq: "p dvd q"  
shows 
  "poly_mod.eq_m r C (D' * H')" 
  "poly_mod.eq_m r (D' * S' + H' * T') 1"
  "poly_mod.Mp r D' = D'" 
  "poly_mod.Mp r H' = H'" 
  "poly_mod.Mp r S' = S'" 
  "poly_mod.Mp r T' = T'" 
  "poly_mod.Mp p D1 = poly_mod.Mp p D'" 
  "poly_mod.Mp p H1 = poly_mod.Mp p H'" 
  "poly_mod.Mp p S1 = poly_mod.Mp p S'" 
  "poly_mod.Mp p T1 = poly_mod.Mp p T'" 
  "monic D'" 
proof -
  define U where U: "U = poly_mod.Mp p (sdiv_poly (C - D * H) q)" 
  note step = step[unfolded hensel_step_def Let_def, folded U]
  obtain A B where dupe1: "dupe_monic_dynamic p D1 H1 S1 T1 U = (A,B)" by force
  note step = step[unfolded dupe1 split]  
  from step have D': "D' = D + smult q B" and H': "H' = H + smult q A"
    by (auto split: prod.splits)
  define U' where U': "U' = poly_mod.Mp q (sdiv_poly (S * D' + T * H' - 1) p)" 
  obtain A' B' where dupe2: "dupe_monic_dynamic q D H S T U' = (A',B')" by force
  from step[folded D' H', folded U', unfolded dupe2 split, folded rq]  
  have S': "S' = poly_mod.Mp r (S - Polynomial.smult p A')" and
    T': "T' = poly_mod.Mp r (T - Polynomial.smult p B')" by auto
  from hensel_step_main[OF one_q one_p CDHq D1D H1H S1S T1T mon mon1 q p D1 H1 S1 T1 D H S T U 
    dupe1 D' H' U' dupe2 rq pq S' T']
  show "poly_mod.eq_m r (D' * S' + H' * T') 1"
    "poly_mod.eq_m r C (D' * H')" 
    "poly_mod.Mp r D' = D'" 
    "poly_mod.Mp r H' = H'" 
    "poly_mod.Mp r S' = S'" 
    "poly_mod.Mp r T' = T'"
    "monic D'" by auto
  from pq obtain s where q: "q = p * s" by (metis dvdE)
  show "poly_mod.Mp p D1 = poly_mod.Mp p D'" 
    "poly_mod.Mp p H1 = poly_mod.Mp p H'" 
    unfolding q D' D1D H' H1H
    by (metis add.right_neutral poly_mod.Mp_smult_m_0 poly_mod.plus_Mp(2) smult_smult)+  
  from q > 1 have q0: "q > 0" by auto
  show "poly_mod.Mp p S1 = poly_mod.Mp p S'" 
    "poly_mod.Mp p T1 = poly_mod.Mp p T'" 
    unfolding S' S1S T' T1T poly_mod_2.Mp_product_modulus[OF poly_mod_2.intro[OF p > 1] rq q0]
    by (metis group_add_class.diff_0_right poly_mod.Mp_smult_m_0 poly_mod.minus_Mp(2))+  
qed

lemma quadratic_hensel_step: assumes step: "quadratic_hensel_step q S T D H = (S', T', D', H')"
  and CDH: "poly_mod.eq_m q C (D * H)"
  and one: "poly_mod.eq_m q (D * S + H * T) 1"
  and D: "poly_mod.Mp q D = D" 
  and H: "poly_mod.Mp q H = H"
  and S: "poly_mod.Mp q S = S" 
  and T: "poly_mod.Mp q T = T"
  and mon: "monic D" 
  and q: "q > 1" 
  and rq: "r = q * q" 
shows 
  "poly_mod.eq_m r C (D' * H')" 
  "poly_mod.eq_m r (D' * S' + H' * T') 1"
  "poly_mod.Mp r D' = D'" 
  "poly_mod.Mp r H' = H'" 
  "poly_mod.Mp r S' = S'" 
  "poly_mod.Mp r T' = T'" 
  "poly_mod.Mp q D = poly_mod.Mp q D'" 
  "poly_mod.Mp q H = poly_mod.Mp q H'" 
  "poly_mod.Mp q S = poly_mod.Mp q S'" 
  "poly_mod.Mp q T = poly_mod.Mp q T'" 
  "monic D'" 
proof (atomize(full), goal_cases)
  case 1
  from hensel_step[OF step[unfolded quadratic_hensel_step_def] one mon q CDH one refl refl refl refl mon q D H S T D H S T rq]
  show ?case by auto
qed

context
  fixes p :: int and S1 T1 D1 H1 :: "int poly" 
begin
private lemma decrease[termination_simp]: "¬ j  1  odd j  Suc (j div 2) < j" by presburger

fun quadratic_hensel_loop where 
  "quadratic_hensel_loop (j :: nat) = (
      if j  1 then (p, S1, T1, D1, H1) else
      if even j then 
          (case quadratic_hensel_loop (j div 2) of
             (q, S, T, D, H) 
          let qq = q * q in 
          (case quadratic_hensel_step q S T D H of ― ‹quadratic step›
            (S', T', D', H')  (qq, S', T', D', H')))
     else ― ‹odd j›
        (case quadratic_hensel_loop (j div 2 + 1) of
           (q, S, T, D, H)        
          (case quadratic_hensel_step q S T D H of ― ‹quadratic step›
            (S', T', D', H')  
                let qq = q * q; pj = qq div p; down = poly_mod.Mp pj in
                  (pj, down S', down T', down D', down H'))))"

definition "quadratic_hensel_main j = (case quadratic_hensel_loop j of 
    (qq, S, T, D, H)  (D, H))" 

declare quadratic_hensel_loop.simps[simp del]

― ‹unroll the definition of hensel_loop› so that in outermost iteration we can use simple_hensel_step›
lemma quadratic_hensel_main_code[code]: "quadratic_hensel_main j = (
   if j  1 then (D1, H1)
      else if even j
      then (case quadratic_hensel_loop (j div 2) of
            (q, S, T, D, H) 
               simple_quadratic_hensel_step q S T D H)            
       else (case quadratic_hensel_loop (j div 2 + 1) of
            (q, S, T, D, H) 
              (case simple_quadratic_hensel_step q S T D H of 
                (D', H')  let down = poly_mod.Mp (q * q div p) in (down D', down H'))))"
  unfolding quadratic_hensel_loop.simps[of j] quadratic_hensel_main_def Let_def 
  by (simp split: if_splits prod.splits option.splits sum.splits 
      add: quadratic_hensel_step_code simple_quadratic_hensel_step_def Let_def)


context
  fixes j :: nat 
  assumes 1: "poly_mod.eq_m p (D1 * S1 + H1 * T1) 1"
  and CDH1: "poly_mod.eq_m p C (D1 * H1)" 
  and mon1: "monic D1" 
  and p: "p > 1" 
  and D1: "poly_mod.Mp p D1 = D1" 
  and H1: "poly_mod.Mp p H1 = H1"  
  and S1: "poly_mod.Mp p S1 = S1" 
  and T1: "poly_mod.Mp p T1 = T1"  
  and j: "j  1" 
begin

lemma quadratic_hensel_loop:
  assumes "quadratic_hensel_loop j = (q, S, T, D, H)"
  shows "(poly_mod.eq_m q C (D * H)  monic D
     poly_mod.eq_m p D1 D  poly_mod.eq_m p H1 H
     poly_mod.eq_m q (D * S + H * T) 1
     poly_mod.Mp q D = D  poly_mod.Mp q H = H
     poly_mod.Mp q S = S  poly_mod.Mp q T = T
     q = p^j)" 
  using j assms
proof (induct j arbitrary: q S T D H rule: less_induct)
  case (less j q' S' T' D' H')
  note res = less(3)
  interpret poly_mod_2 p using p by (rule poly_mod_2.intro)
  let ?hens = "quadratic_hensel_loop" 
  note simp[simp] = quadratic_hensel_loop.simps[of j]
  show ?case
  proof (cases "j = 1")
    case True
    show ?thesis using res simp unfolding True using CDH1 1 mon1 D1 H1 S1 T1 by auto
  next
    case False
    with less(2) have False: "(j  1) = False" by auto
    have mod_2: "k  1  poly_mod_2 (p^k)" for k by (intro poly_mod_2.intro, insert p, auto)
    {
      fix k D
      assume *: "k  1" "k  j" "poly_mod.Mp (p ^ k) D = D" 
      from *(2) have "{0..<p ^ k}  {0..<p ^ j}" using p by auto
      hence "poly_mod.Mp (p ^ j) D = D" 
        unfolding poly_mod_2.Mp_ident_iff[OF mod_2[OF less(2)]]
        using *(3)[unfolded poly_mod_2.Mp_ident_iff[OF mod_2[OF *(1)]]] by blast
    } note lift_norm = this
    show ?thesis
    proof (cases "even j")
      case True
      let ?j2 = "j div 2" 
      from False have lt: "?j2 < j" "1  ?j2" by auto
      obtain q S T D H where rec: "?hens ?j2 = (q, S, T, D, H)" by (cases "?hens ?j2", auto)
      note IH = less(1)[OF lt rec]
      from IH
      have *: "poly_mod.eq_m q C (D * H)" 
        "poly_mod.eq_m q (D * S + H * T) 1"
        "monic D" 
        "eq_m D1 D" 
        "eq_m H1 H"
        "poly_mod.Mp q D = D"
        "poly_mod.Mp q H = H"
        "poly_mod.Mp q S = S"
        "poly_mod.Mp q T = T"
        "q = p ^ ?j2"
        by auto
      hence norm: "poly_mod.Mp (p ^ j) D = D" "poly_mod.Mp (p ^ j) H = H"
        "poly_mod.Mp (p ^ j) S = S" "poly_mod.Mp (p ^ j) T = T"
        using lift_norm[OF lt(2)] by auto
      from lt p have q: "q > 1" unfolding * by simp
      let ?step = "quadratic_hensel_step q S T D H" 
      obtain S2 T2 D2 H2 where step_res: "?step = (S2, T2, D2, H2)" by (cases ?step, auto)
      note step = quadratic_hensel_step[OF step_res *(1,2,6-9,3) q refl]
      let ?qq = "q * q"
      {
        fix D D2
        assume "poly_mod.Mp q D = poly_mod.Mp q D2" 
        from arg_cong[OF this, of Mp] Mp_Mp_pow_is_Mp[of ?j2, OF _ p, folded *(10)] lt
        have "Mp D = Mp D2" by simp
      } note shrink = this
      have **: "poly_mod.eq_m ?qq C (D2 * H2)" 
        "poly_mod.eq_m ?qq (D2 * S2 + H2 * T2) 1" 
        "monic D2" 
        "eq_m D1 D2"
        "eq_m H1 H2" 
        "poly_mod.Mp ?qq D2 = D2" 
        "poly_mod.Mp ?qq H2 = H2" 
        "poly_mod.Mp ?qq S2 = S2" 
        "poly_mod.Mp ?qq T2 = T2" 
        using step shrink[of H H2] shrink[of D D2] *(4-7) by auto
      note simp = simp False if_False rec split Let_def step_res option.simps
      from True have j: "p ^ j = p ^ (2 * ?j2)" by auto
      with *(10) have qq: "q * q = p ^ j"
        by (simp add: power_mult_distrib semiring_normalization_rules(30-))
      from res[unfolded simp] True have id': "q' = ?qq" "S' = S2" "T' = T2" "D' = D2" "H' = H2" by auto 
      show ?thesis unfolding id' using ** by (auto simp: qq)
    next
      case odd: False
      hence False': "(even j) = False" by auto
      let ?j2 = "j div 2 + 1" 
      from False odd have lt: "?j2 < j" "1  ?j2" by presburger+
      obtain q S T D H where rec: "?hens ?j2 = (q, S, T, D, H)" by (cases "?hens ?j2", auto)
      note IH = less(1)[OF lt rec]
      note simp = simp False if_False rec sum.simps split Let_def False' option.simps
      from IH have *: "poly_mod.eq_m q C (D * H)" 
          "poly_mod.eq_m q (D * S + H * T) 1"
          "monic D" 
          "eq_m D1 D" 
          "eq_m H1 H"
          "poly_mod.Mp q D = D"
          "poly_mod.Mp q H = H"
          "poly_mod.Mp q S = S"
          "poly_mod.Mp q T = T"
          "q = p ^ ?j2"
          by auto
      hence norm: "poly_mod.Mp (p ^ j) D = D" "poly_mod.Mp (p ^ j) H = H" 
        using lift_norm[OF lt(2)] lt by auto
      from lt p have q: "q > 1" unfolding *
        using mod_2 poly_mod_2.m1 by blast
      let ?step = "quadratic_hensel_step q S T D H" 
      obtain S2 T2 D2 H2 where step_res: "?step = (S2, T2, D2, H2)" by (cases ?step, auto)
      have dvd: "q dvd q" by auto
      note step = quadratic_hensel_step[OF step_res *(1,2,6-9,3) q refl]         
      let ?qq = "q * q"
      {
        fix D D2
        assume "poly_mod.Mp q D = poly_mod.Mp q D2" 
        from arg_cong[OF this, of Mp] Mp_Mp_pow_is_Mp[of ?j2, OF _ p, folded *(10)] lt
        have "Mp D = Mp D2" by simp
      } note shrink = this
      have **: "poly_mod.eq_m ?qq C (D2 * H2)" 
        "poly_mod.eq_m ?qq (D2 * S2 + H2 * T2) 1" 
        "monic D2" 
        "eq_m D1 D2"
        "eq_m H1 H2" 
        "poly_mod.Mp ?qq D2 = D2" 
        "poly_mod.Mp ?qq H2 = H2" 
        "poly_mod.Mp ?qq S2 = S2"
        "poly_mod.Mp ?qq T2 = T2"
        using step shrink[of H H2] shrink[of D D2] *(4-7) by auto
      note simp = simp False if_False rec split Let_def step_res option.simps
      from odd have j: "Suc j = 2 * ?j2" by auto
      from arg_cong[OF this, of "λ j. p ^ j div p"]
      have pj: "p ^ j = q * q div p" and qq: "q * q = p ^ j * p" unfolding *(10) using p
        by (simp add: power_mult_distrib semiring_normalization_rules(30-))+
      let ?pj = "p ^ j" 
      from res[unfolded simp] pj
      have id: 
        "q' = p^j" 
        "S' = poly_mod.Mp ?pj S2" 
        "T' = poly_mod.Mp ?pj T2" 
        "D' = poly_mod.Mp ?pj D2" 
        "H' = poly_mod.Mp ?pj H2" 
        by auto
      interpret pj: poly_mod_2 ?pj by (rule mod_2[OF 1  j])
      have norm: "pj.Mp D' = D'" "pj.Mp H' = H'"
        unfolding id by (auto simp: poly_mod.Mp_Mp)
      have mon: "monic D'" using pj.monic_Mp[OF step(11)] unfolding id .
      have id': "Mp (pj.Mp D) = Mp D" for D using 1  j
        by (simp add: Mp_Mp_pow_is_Mp p)
      have eq: "eq_m D1 D2  eq_m D1 (pj.Mp D2)" for D1 D2 
        unfolding id' by auto
      have id'': "pj.Mp (poly_mod.Mp (q * q) D) = pj.Mp D" for D
        unfolding qq by (rule pj.Mp_product_modulus[OF refl], insert p, auto)
      {
        fix D1 D2
        assume "poly_mod.eq_m (q * q) D1 D2" 
        hence "poly_mod.Mp (q * q) D1 = poly_mod.Mp (q * q) D2" by simp
        from arg_cong[OF this, of pj.Mp] 
        have "pj.Mp D1 = pj.Mp D2" unfolding id'' .
      } note eq' = this
      from eq'[OF step(1)] have eq1: "pj.eq_m C (D' * H')" unfolding id by simp
      from eq'[OF step(2)] have eq2: "pj.eq_m (D' * S' + H' * T') 1" 
        unfolding id by (metis pj.mult_Mp pj.plus_Mp)
      from **(4-5) have eq3: "eq_m D1 D'" "eq_m H1 H'" 
        unfolding id by (auto intro: eq)
      from norm mon eq1 eq2 eq3
      show ?thesis unfolding id by simp
    qed
  qed
qed

lemma quadratic_hensel_main: assumes res: "quadratic_hensel_main j = (D,H)" 
  shows "poly_mod.eq_m (p^j) C (D * H)"
  "monic D" 
  "poly_mod.eq_m p D1 D" 
  "poly_mod.eq_m p H1 H" 
  "poly_mod.Mp (p^j) D = D" 
  "poly_mod.Mp (p^j) H = H" 
proof (atomize(full), goal_cases)
  case 1
  let ?hen = "quadratic_hensel_loop j"
  from res obtain q S T where hen: "?hen = (q, S, T, D, H)" 
    by (cases ?hen, auto simp: quadratic_hensel_main_def)
  from quadratic_hensel_loop[OF hen] show ?case by auto
qed
end
end
end

datatype 'a factor_tree = Factor_Leaf 'a "int poly" | Factor_Node 'a "'a factor_tree" "'a factor_tree" 

fun factor_node_info :: "'a factor_tree  'a" where
  "factor_node_info (Factor_Leaf i x) = i" 
| "factor_node_info (Factor_Node i l r) = i" 
  
fun factors_of_factor_tree :: "'a factor_tree  int poly multiset" where
  "factors_of_factor_tree (Factor_Leaf i x) = {#x#}" 
| "factors_of_factor_tree (Factor_Node i l r) = factors_of_factor_tree l + factors_of_factor_tree r"
  
fun product_factor_tree :: "int  'a factor_tree  int poly factor_tree" where
  "product_factor_tree p (Factor_Leaf i x) = (Factor_Leaf x x)" 
| "product_factor_tree p (Factor_Node i l r) = (let 
    L = product_factor_tree p l;
    R = product_factor_tree p r;
    f = factor_node_info L;
    g = factor_node_info R;
    fg = poly_mod.Mp p (f * g) 
   in Factor_Node fg L R)"
  
fun sub_trees :: "'a factor_tree  'a factor_tree set" where
  "sub_trees (Factor_Leaf i x) = {Factor_Leaf i x}" 
| "sub_trees (Factor_Node i l r) = insert (Factor_Node i l r) (sub_trees l  sub_trees r)" 
  
lemma sub_trees_refl[simp]: "t  sub_trees t" by (cases t, auto)
  
lemma product_factor_tree: assumes " x. x ∈# factors_of_factor_tree t  poly_mod.Mp p x = x" 
  shows "u  sub_trees (product_factor_tree p t)  factor_node_info u = f  
  poly_mod.Mp p f = f  f = poly_mod.Mp p (prod_mset (factors_of_factor_tree u))  
  factors_of_factor_tree (product_factor_tree p t) = factors_of_factor_tree t" 
  using assms
proof (induct t arbitrary: u f)
  case (Factor_Node i l r u f)
  interpret poly_mod p . 
  let ?L = "product_factor_tree p l" 
  let ?R = "product_factor_tree p r"
  let ?f = "factor_node_info ?L"
  let ?g = "factor_node_info ?R"
  let ?fg = "Mp (?f * ?g)" 
  have "Mp ?f = ?f  ?f = Mp (prod_mset (factors_of_factor_tree ?L)) 
      (factors_of_factor_tree ?L) = (factors_of_factor_tree l)"      
      by (rule Factor_Node(1)[OF sub_trees_refl refl], insert Factor_Node(5), auto)
  hence IH1: "?f = Mp (prod_mset (factors_of_factor_tree ?L))" 
      "(factors_of_factor_tree ?L) = (factors_of_factor_tree l)" by blast+
  have "Mp ?g = ?g  ?g = Mp (prod_mset (factors_of_factor_tree ?R)) 
      (factors_of_factor_tree ?R) = (factors_of_factor_tree r)" 
      by (rule Factor_Node(2)[OF sub_trees_refl refl], insert Factor_Node(5), auto)
  hence IH2: "?g = Mp (prod_mset (factors_of_factor_tree ?R))" 
      "(factors_of_factor_tree ?R) = (factors_of_factor_tree r)" by blast+
  have id: "(factors_of_factor_tree (product_factor_tree p (Factor_Node i l r))) =
    (factors_of_factor_tree (Factor_Node i l r))" by (simp add: Let_def IH1 IH2)
  from Factor_Node(3) consider (root) "u = Factor_Node ?fg ?L ?R" 
    | (l) "u  sub_trees ?L" | (r) "u  sub_trees ?R" 
    by (auto simp: Let_def)  
  thus ?case
  proof cases
    case root
    with Factor_Node have f: "f = ?fg" by auto
    show ?thesis unfolding f root id by (simp add: Let_def ac_simps IH1 IH2)
  next
    case l
    have "Mp f = f  f = Mp (prod_mset (factors_of_factor_tree u))" 
      using Factor_Node(1)[OF l Factor_Node(4)] Factor_Node(5) by auto
    thus ?thesis unfolding id by blast
  next
    case r
    have "Mp f = f  f = Mp (prod_mset (factors_of_factor_tree u))" 
      using Factor_Node(2)[OF r Factor_Node(4)] Factor_Node(5) by auto
    thus ?thesis unfolding id by blast
  qed
qed auto

fun create_factor_tree_simple :: "int poly list  unit factor_tree" where
  "create_factor_tree_simple xs = (let n = length xs in if n  1 then Factor_Leaf () (hd xs)
    else let i = n div 2;
      xs1 = take i xs;
      xs2 = drop i xs
      in Factor_Node () (create_factor_tree_simple xs1) (create_factor_tree_simple xs2)
      )" 
  
declare create_factor_tree_simple.simps[simp del]
  
lemma create_factor_tree_simple: "xs  []  factors_of_factor_tree (create_factor_tree_simple xs) = mset xs" 
proof (induct xs rule: wf_induct[OF wf_measure[of length]])
  case (1 xs)
  from 1(2) have xs: "length xs  0" by auto
  then consider (base) "length xs = 1" | (step) "length xs > 1" by linarith
  thus ?case
  proof cases
    case base
    then obtain x where xs: "xs = [x]" by (cases xs; cases "tl xs"; auto)
    thus ?thesis by (auto simp: create_factor_tree_simple.simps)
  next
    case step
    let ?i = "length xs div 2" 
    let ?xs1 = "take ?i xs" 
    let ?xs2 = "drop ?i xs" 
    from step have xs1: "(?xs1, xs)  measure length" "?xs1  []" by auto
    from step have xs2: "(?xs2, xs)  measure length" "?xs2  []" by auto
    from step have id: "create_factor_tree_simple xs = Factor_Node () (create_factor_tree_simple (take ?i xs))
            (create_factor_tree_simple (drop ?i xs))" unfolding create_factor_tree_simple.simps[of xs] Let_def by auto
    have xs: "xs = ?xs1 @ ?xs2" by auto
    show ?thesis unfolding id arg_cong[OF xs, of mset] mset_append
      using 1(1)[rule_format, OF xs1] 1(1)[rule_format, OF xs2]
      by auto
  qed
qed

text ‹We define a better factorization tree which balances the trees according to their degree.,
  cf. Modern Computer Algebra, Chapter 15.5 on Multifactor Hensel lifting.›
  
fun partition_factors_main :: "nat  ('a × nat) list  ('a × nat) list × ('a × nat) list" where
  "partition_factors_main s [] = ([], [])" 
| "partition_factors_main s ((f,d) # xs) = (if d  s then case partition_factors_main (s - d) xs of
     (l,r)  ((f,d) # l, r) else case partition_factors_main d xs of 
     (l,r)  (l, (f,d) # r))" 
  
lemma partition_factors_main: "partition_factors_main s xs = (a,b)  mset xs = mset a + mset b" 
  by (induct s xs arbitrary: a b rule: partition_factors_main.induct, auto split: if_splits prod.splits)

definition partition_factors :: "('a × nat) list  ('a × nat) list × ('a × nat) list" where
  "partition_factors xs = (let n = sum_list (map snd xs) div 2 in
     case partition_factors_main n xs of
     ([], x # y # ys)  ([x], y # ys)
   | (x # y # ys, [])  ([x], y # ys)
   | pair  pair)" 
  
lemma partition_factors: "partition_factors xs = (a,b)  mset xs = mset a + mset b"
  unfolding partition_factors_def Let_def 
  by (cases "partition_factors_main (sum_list (map snd xs) div 2) xs", auto split: list.splits
    simp: partition_factors_main)

lemma partition_factors_length: assumes "¬ length xs  1" "(a,b) = partition_factors xs"
  shows [termination_simp]: "length a < length xs" "length b < length xs" and "a  []" "b  []" 
proof -
  obtain ys zs where main: "partition_factors_main (sum_list (map snd xs) div 2) xs = (ys,zs)" by force
  note res = assms(2)[unfolded partition_factors_def Let_def main split]
  from arg_cong[OF partition_factors_main[OF main], of size] have len: "length xs = length ys + length zs" by auto
  with assms(1) have len2: "length ys + length zs  2" by auto
  from res len2 have "length a < length xs  length b < length xs  a  []  b  []" unfolding len
    by (cases ys; cases zs; cases "tl ys"; cases "tl zs"; auto)
  thus "length a < length xs" "length b < length xs" "a  []" "b  []" by blast+
qed 
  
fun create_factor_tree_balanced :: "(int poly × nat)list  unit factor_tree" where
  "create_factor_tree_balanced xs = (if length xs  1 then Factor_Leaf () (fst (hd xs)) else
     case partition_factors xs of (l,r)  Factor_Node () 
      (create_factor_tree_balanced l)
      (create_factor_tree_balanced r))" 

definition create_factor_tree :: "int poly list  unit factor_tree" where
  "create_factor_tree xs = (let ys = map (λ f. (f, degree f)) xs;
     zs = rev (sort_key snd ys)
     in create_factor_tree_balanced zs)" 

lemma create_factor_tree_balanced: "xs  []  factors_of_factor_tree (create_factor_tree_balanced xs) = mset (map fst xs)" 
proof (induct xs rule: create_factor_tree_balanced.induct)
  case (1 xs)
  show ?case
  proof (cases "length xs  1")
    case True
    with 1(3) obtain x where xs: "xs = [x]" by (cases xs; cases "tl xs", auto)
    show ?thesis unfolding xs by auto
  next
    case False
    obtain a b where part: "partition_factors xs = (a,b)" by force
    note abp = this[symmetric]
    note nonempty = partition_factors_length(3-4)[OF False abp]
    note IH = 1(1)[OF False abp nonempty(1)] 1(2)[OF False abp nonempty(2)]
    show ?thesis unfolding create_factor_tree_balanced.simps[of xs] part split using 
      False IH partition_factors[OF part] by auto
  qed
qed

lemma create_factor_tree: assumes "xs  []"
  shows "factors_of_factor_tree (create_factor_tree xs) = mset xs" 
proof -
  let ?xs = "rev (sort_key snd (map (λf. (f, degree f)) xs))" 
  from assms have "set xs  {}" by auto
  hence "set ?xs  {}" by auto
  hence xs: "?xs  []" by blast
  show ?thesis unfolding create_factor_tree_def Let_def create_factor_tree_balanced[OF xs]
    by (auto, induct xs, auto)
qed

context
  fixes p :: int and n :: nat
begin

definition quadratic_hensel_binary :: "int poly  int poly  int poly  int poly × int poly" where
  "quadratic_hensel_binary C D H = (
     case euclid_ext_poly_dynamic p D H of 
      (S,T)  quadratic_hensel_main C p S T D H n)" 

fun hensel_lifting_main :: "int poly  int poly factor_tree  int poly list" where
  "hensel_lifting_main U (Factor_Leaf _ _) = [U]"
| "hensel_lifting_main U (Factor_Node _ l r) = (let 
    v = factor_node_info l;
    w = factor_node_info r;
    (V,W) = quadratic_hensel_binary U v w
    in hensel_lifting_main V l @ hensel_lifting_main W r)"

definition hensel_lifting_monic :: "int poly  int poly list  int poly list" where
  "hensel_lifting_monic u vs = (if vs = [] then [] else let 
     pn = p^n; 
     C = poly_mod.Mp pn u;
     tree = product_factor_tree p (create_factor_tree vs)
     in hensel_lifting_main C tree)" 

definition hensel_lifting :: "int poly  int poly list  int poly list" where 
  "hensel_lifting f gs = (let lc = lead_coeff f; 
     ilc = inverse_mod lc (p^n);
     g = smult ilc f
     in hensel_lifting_monic g gs)"

end


context poly_mod_prime begin

context
  fixes n :: nat
  assumes n: "n  0" 
begin

abbreviation "hensel_binary  quadratic_hensel_binary p n" 

abbreviation "hensel_main  hensel_lifting_main p n" 

lemma hensel_binary: 
  assumes cop: "coprime_m D H" and eq: "eq_m C (D * H)"
  and normalized_input: "Mp D = D" "Mp H = H"
  and monic_input: "monic D" 
  and hensel_result: "hensel_binary C D H = (D',H')" 
  shows "poly_mod.eq_m (p^n) C (D' * H') ― ‹the main result: equivalence mod p^n›
     monic D' ― ‹monic output›
     eq_m D D'  eq_m H H' ― ‹apply `mod p`› on D'› and H'› yields D› and H› again›
     poly_mod.Mp (p^n) D' = D'  poly_mod.Mp (p^n) H' = H' ― ‹output is normalized›"
proof -
  from m1 have p: "p > 1" .
  obtain S T where ext: "euclid_ext_poly_dynamic p D H = (S,T)" by force
  obtain D1 H1 where main: "quadratic_hensel_main C p S T D H n = (D1,H1)" by force
  note hen = hensel_result[unfolded quadratic_hensel_binary_def ext split Let_def main]
  from n have n: "n  1" by simp
  note eucl = euclid_ext_poly_dynamic[OF cop normalized_input ext]
  note main = quadratic_hensel_main[OF eucl(1) eq monic_input p normalized_input eucl(2-) n main]
  show ?thesis using hen main by auto
qed

lemma hensel_main: 
  assumes eq: "eq_m C (prod_mset (factors_of_factor_tree Fs))"
  and " F. F ∈# factors_of_factor_tree Fs  Mp F = F  monic F"  
  and hensel_result: "hensel_main C Fs = Gs" 
  and C: "monic C" "poly_mod.Mp (p^n) C = C" 
  and sf: "square_free_m C" 
  and " f t. t  sub_trees Fs  factor_node_info t = f  f = Mp (prod_mset (factors_of_factor_tree t))"
  shows "poly_mod.eq_m (p^n) C (prod_list Gs) ― ‹the main result: equivalence mod p^n›
     factors_of_factor_tree Fs = mset (map Mp Gs)
     ( G. G  set Gs  monic G  poly_mod.Mp (p^n) G = G)"
  using assms
proof (induct Fs arbitrary: C Gs)
  case (Factor_Leaf f fs C Gs)
  thus ?case by auto
next
  case (Factor_Node f l r C Gs) note * = this
  note simps = hensel_lifting_main.simps
  note IH1 = *(1)[rule_format]
  note IH2 = *(2)[rule_format]
  note res = *(5)[unfolded simps Let_def]
  note eq = *(3)
  note Fs = *(4)
  note C = *(6,7)
  note sf = *(8)
  note inv = *(9)
  interpret pn: poly_mod_2 "p^n" apply (unfold_locales) using m1 n by auto
  let ?Mp = "pn.Mp"
  define D where "D  prod_mset (factors_of_factor_tree l)" 
  define H where "H  prod_mset (factors_of_factor_tree r)" 
  let ?D = "Mp D" 
  let ?H = "Mp H"
  let ?D' = "factor_node_info l" 
  let ?H' = "factor_node_info r" 
  obtain A B where hen: "hensel_binary C ?D' ?H' = (A,B)" by force
  note res = res[unfolded hen split]  
  obtain AD where AD': "AD = hensel_main A l" by auto
  obtain BH where BH': "BH = hensel_main B r" by auto
  from inv[of l, OF _ refl] have D': "?D' = ?D" unfolding D_def by auto
  from inv[of r, OF _ refl] have H': "?H' = ?H" unfolding H_def by auto
  from eq[simplified]
  have eq': "Mp C = Mp (?D * ?H)" unfolding D_def H_def by simp
  from square_free_m_cong[OF sf, of "?D * ?H", OF eq'] 
  have sf': "square_free_m (?D * ?H)" .
  from poly_mod_prime.square_free_m_prod_imp_coprime_m[OF _ this]
  have cop': "coprime_m ?D ?H" unfolding poly_mod_prime_def using prime .
  from eq' have eq': "eq_m C (?D * ?H)" by simp
  have monD: "monic D" unfolding D_def by (rule monic_prod_mset, insert Fs, auto)
  from hensel_binary[OF _ _ _ _ _ hen, unfolded D' H', OF cop' eq' Mp_Mp Mp_Mp monic_Mp[OF monD]] 
  have step: "poly_mod.eq_m (p ^ n) C (A * B)  monic A  eq_m ?D A 
     eq_m ?H B  ?Mp A = A  ?Mp B = B" .
  from res have Gs: "Gs = AD @ BH" by (simp add: AD' BH')
  have AD: "eq_m A ?D" "?Mp A = A" "eq_m A (prod_mset (factors_of_factor_tree l))"  
    and monA: "monic A"
    using step by (auto simp: D_def)
  note sf_fact = square_free_m_factor[OF sf']
  from square_free_m_cong[OF sf_fact(1)] AD have sfA: "square_free_m A" by auto
  have IH1: "poly_mod.eq_m (p ^ n) A (prod_list AD) 
    factors_of_factor_tree l = mset (map Mp AD) 
    (G. G  set AD  monic G  ?Mp G = G)"
    by (rule IH1[OF AD(3) Fs AD'[symmetric] monA AD(2) sfA inv], auto)
  have BH: "eq_m B ?H" "pn.Mp B = B" "eq_m B (prod_mset (factors_of_factor_tree r))"
      using step by (auto simp: H_def)
  from step have "pn.eq_m C (A * B)" by simp
  hence "?Mp C = ?Mp (A * B)" by simp
  with C AD(2) have "pn.Mp C = pn.Mp (A * pn.Mp B)" by simp
  from arg_cong[OF this, of lead_coeff] C
  have "monic (pn.Mp (A * B))" by simp
  then have "lead_coeff (pn.Mp A) * lead_coeff (pn.Mp B) = 1"
    by (metis lead_coeff_mult leading_coeff_neq_0 local.step mult_cancel_right2 pn.degree_m_eq pn.m1 poly_mod.M_def poly_mod.Mp_coeff)
  with monA AD(2) BH(2) have monB: "monic B" by simp
  from square_free_m_cong[OF sf_fact(2)] BH have sfB: "square_free_m B" by auto
  have IH2: "poly_mod.eq_m (p ^ n) B (prod_list BH) 
      factors_of_factor_tree r = mset (map Mp BH) 
      (G. G  set BH  monic G  ?Mp G = G)" 
    by (rule IH2[OF BH(3) Fs BH'[symmetric] monB BH(2) sfB inv], auto)
  from step have "?Mp C = ?Mp (?Mp A * ?Mp B)" by auto
  also have "?Mp A = ?Mp (prod_list AD)" using IH1 by auto
  also have "?Mp B = ?Mp (prod_list BH)" using IH2 by auto
  finally have "poly_mod.eq_m (p ^ n) C (prod_list AD * prod_list BH)" 
    by (auto simp: poly_mod.mult_Mp)
  thus ?case unfolding Gs using IH1 IH2 by auto
qed

lemma hensel_lifting_monic: 
  assumes eq: "poly_mod.eq_m p C (prod_list Fs)"
  and Fs: " F. F  set Fs  poly_mod.Mp p F = F  monic F"  
  and res: "hensel_lifting_monic p n C Fs = Gs" 
  and mon: "monic (poly_mod.Mp (p^n) C)" 
  and sf: "poly_mod.square_free_m p C"
  shows "poly_mod.eq_m (p^n) C (prod_list Gs)"
    "mset (map (poly_mod.Mp p) Gs) = mset Fs" 
    "G  set Gs  monic G  poly_mod.Mp (p^n) G = G"
proof -
  note res = res[unfolded hensel_lifting_monic_def Let_def]
  let ?Mp = "poly_mod.Mp (p ^ n)" 
  let ?C = "?Mp C" 
  interpret poly_mod_prime p
    by (unfold_locales, insert n prime, auto)
  interpret pn: poly_mod_2 "p^n" using m1 n poly_mod_2.intro by auto
  from eq n have eq: "eq_m (?Mp C) (prod_list Fs)"
    using Mp_Mp_pow_is_Mp eq m1 n by force
  have "poly_mod.eq_m (p^n) C (prod_list Gs)  mset (map (poly_mod.Mp p) Gs) = mset Fs
     (G  set Gs  monic G  poly_mod.Mp (p^n) G = G)" 
  proof (cases "Fs = []")
    case True
    with res have Gs: "Gs = []" by auto
    from eq have "Mp ?C = 1" unfolding True by simp
    hence "degree (Mp ?C) = 0" by simp
    with degree_m_eq_monic[OF mon m1] have "degree ?C = 0" by simp
    with mon have "?C = 1" using monic_degree_0 by blast
    thus ?thesis unfolding True Gs by auto
  next
    case False
    let ?t = "create_factor_tree Fs" 
    note tree = create_factor_tree[OF False]
    from False res have hen: "hensel_main ?C (product_factor_tree p ?t) = Gs" by auto
    have tree1: "x ∈# factors_of_factor_tree ?t  Mp x = x" for x unfolding tree using Fs by auto
    from product_factor_tree[OF tree1 sub_trees_refl refl, of ?t]
    have id: "(factors_of_factor_tree (product_factor_tree p ?t)) =
        (factors_of_factor_tree ?t)" by auto
    have eq: "eq_m ?C (prod_mset (factors_of_factor_tree (product_factor_tree p ?t)))"
      unfolding id tree using eq by auto  
    have id': "Mp C = Mp ?C" using n by (simp add: Mp_Mp_pow_is_Mp m1)
    have "pn.eq_m ?C (prod_list Gs)  mset Fs = mset (map Mp Gs)  (G. G  set Gs  monic G  pn.Mp G = G)"
      by (rule hensel_main[OF eq Fs hen mon pn.Mp_Mp square_free_m_cong[OF sf id'], unfolded id tree],
      insert product_factor_tree[OF tree1], auto)
    thus ?thesis by auto
  qed
  thus "poly_mod.eq_m (p^n) C (prod_list Gs)"
    "mset (map (poly_mod.Mp p) Gs) = mset Fs" 
    "G  set Gs  monic G  poly_mod.Mp (p^n) G = G" by blast+
qed

lemma hensel_lifting:
  assumes res: "hensel_lifting p n f fs = gs"                      ― ‹result of hensel is fact. gs›
    and cop: "coprime (lead_coeff f) p"
    and sf: "poly_mod.square_free_m p f"
    and fact: "poly_mod.factorization_m p f (c, mset fs)"          ― ‹input is fact. fs mod p›
    and c: "c  {0..<p}"
    and norm: "(fiset fs. set (coeffs fi)  {0..<p})"
  shows "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs) ― ‹factorization mod p^n›"
      "sort (map degree fs) = sort (map degree gs)                ― ‹degrees stay the same›"
      " g. g  set gs  monic g  poly_mod.Mp (p^n) g = g    ― ‹monic and normalized›
        irreducible_m g                                ― ‹irreducibility even mod p›
        degree_m g = degree g   ― ‹mod p› does not change degree of g›"
proof -
  interpret poly_mod_prime p using prime by unfold_locales
  interpret q: poly_mod_2 "p^n" using m1 n unfolding poly_mod_2_def by auto
  from fact have eq: "eq_m f (smult c (prod_list fs))"  
    and mon_fs: "(fiset fs. monic (Mp fi)  irreducibled_m fi)"
    unfolding factorization_m_def by auto
  {
    fix f
    assume "f  set fs" 
    with mon_fs norm have "set (coeffs f)  {0..<p}" and "monic (Mp f)" by auto
    hence "monic f" using Mp_ident_iff' by force
  } note mon_fs' = this
  have Mp_id: " f. Mp (q.Mp f) = Mp f" by (simp add: Mp_Mp_pow_is_Mp m1 n)
  let ?lc = "lead_coeff f" 
  let ?q = "p ^ n" 
  define ilc where "ilc  inverse_mod ?lc ?q" 
  define F where "F  smult ilc f" 
  from res[unfolded hensel_lifting_def Let_def] 
  have hen: "hensel_lifting_monic p n F fs = gs" 
    unfolding ilc_def F_def .
  from m1 n cop have inv: "q.M (ilc * ?lc) = 1"
    by (auto simp add: q.M_def inverse_mod_pow ilc_def)
  hence ilc0: "ilc  0" by (cases "ilc = 0", auto)
  {
    fix q
    assume "ilc * ?lc = ?q * q" 
    from arg_cong[OF this, of q.M] have "q.M (ilc * ?lc) = 0" 
      unfolding q.M_def by auto
    with inv have False by auto
  } note not_dvd = this
  have mon: "monic (q.Mp F)" unfolding F_def q.Mp_coeff coeff_smult
    by (subst q.degree_m_eq [OF _ q.m1]) (auto simp: inv ilc0 [symmetric] intro: not_dvd)
  have "q.Mp f = q.Mp (smult (q.M (?lc * ilc)) f)" using inv by (simp add: ac_simps)
  also have " = q.Mp (smult ?lc F)" by (simp add: F_def)
  finally have f: "q.Mp f = q.Mp (smult ?lc F)" .
  from arg_cong[OF f, of Mp]
  have f_p: "Mp f = Mp (smult ?lc F)" 
    by (simp add: Mp_Mp_pow_is_Mp n m1)
  from arg_cong[OF this, of square_free_m, unfolded Mp_square_free_m] sf
  have "square_free_m (smult ?lc F)" by simp
  from square_free_m_smultD[OF this] have sf: "square_free_m F" .
  
  define c' where "c'  M (c * ilc)"
  from factorization_m_smult[OF fact, of ilc, folded F_def] 
  have fact: "factorization_m F (c', mset fs)" unfolding c'_def factorization_m_def by auto
  hence eq: "eq_m F (smult c' (prod_list fs))" unfolding factorization_m_def by auto
  from factorization_m_lead_coeff[OF fact] monic_Mp[OF mon, unfolded Mp_id] have "M c' = 1" 
    by auto
  hence c': "c' = 1" unfolding c'_def by auto
  with eq have eq: "eq_m F (prod_list fs)" by auto 
  {
    fix f
    assume "f  set fs" 
    with mon_fs' norm have "Mp f = f  monic f" unfolding Mp_ident_iff'
      by auto
  } note fs = this
  note hen = hensel_lifting_monic[OF eq fs hen mon sf]
  from hen(2) have gs_fs: "mset (map Mp gs) = mset fs" by auto
  have eq: "q.eq_m f (smult ?lc (prod_list gs))" 
    unfolding f using arg_cong[OF hen(1), of "λ f. q.Mp (smult ?lc f)"] by simp
  {
    fix g 
    assume g: "g  set gs"
    from hen(3)[OF _ g] have mon_g: "monic g" and Mp_g: "q.Mp g = g" by auto
    from g have "Mp g ∈# mset (map Mp gs)" by auto
    from this[unfolded gs_fs] obtain f where f: "f  set fs" and fg: "eq_m f g" by auto
    from mon_fs f fs have irr_f: "irreducibled_m f" and mon_f: "monic f" and Mp_f: "Mp f = f" by auto
    have deg: "degree_m g = degree g" 
      by (rule degree_m_eq_monic[OF mon_g m1])
    from irr_f fg have irr_g: "irreducibled_m g" 
      unfolding irreducibled_m_def dvdm_def by simp
    have "q.irreducibled_m g"
      by (rule irreducibled_lifting[OF n _ irr_g], unfold deg, rule q.degree_m_eq_monic[OF mon_g q.m1])
    note mon_g Mp_g deg irr_g this
  } note g = this
  {
    fix g
    assume "g  set gs" 
    from g[OF this]
    show "monic g  q.Mp g = g  irreducible_m g  degree_m g = degree g" by auto
  }
  show "sort (map degree fs) = sort (map degree gs)" 
  proof (rule sort_key_eq_sort_key)
    have "mset (map degree fs) = image_mset degree (mset fs)" by auto
    also have " = image_mset degree (mset (map Mp gs))" unfolding gs_fs ..
    also have " = mset (map degree (map Mp gs))" unfolding mset_map ..
    also have "map degree (map Mp gs) = map degree_m gs" by auto
    also have " = map degree gs" using g(3) by auto
    finally show "mset (map degree fs) = mset (map degree gs)" .
  qed auto
  show "q.factorization_m f (lead_coeff f, mset gs)" 
    using eq g unfolding q.factorization_m_def by auto
qed

end

end
end

Theory Hensel_Lifting_Type_Based

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
theory Hensel_Lifting_Type_Based
imports Hensel_Lifting
begin


subsection‹Hensel Lifting in a Type-Based Setting›

(* TODO: Move? *)

lemma degree_smult_eq_iff:
  "degree (smult a p) = degree p  degree p = 0  a * lead_coeff p  0"
  by (metis (no_types, lifting) coeff_smult degree_0 degree_smult_le le_antisym 
      le_degree le_zero_eq leading_coeff_0_iff)

lemma degree_smult_eqI[intro!]:
  assumes "degree p  0  a * lead_coeff p  0"
  shows "degree (smult a p) = degree p"
  using assms degree_smult_eq_iff by auto

lemma degree_mult_eq2:
  assumes lc: "lead_coeff p * lead_coeff q  0"
  shows "degree (p * q) = degree p + degree q" (is "_ = ?r")
proof(intro antisym[OF degree_mult_le] le_degree, unfold coeff_mult)
  let ?f = "λi. coeff p i * coeff q (?r - i)"
  have "(i?r. ?f i) = sum ?f {..degree p} + sum ?f {Suc (degree p)..?r}"
    by (rule sum_up_index_split)
  also have "sum ?f {Suc (degree p)..?r} = 0"
    proof-
      { fix x assume "x > degree p"
        then have "coeff p x = 0" by (rule coeff_eq_0)
        then have "?f x = 0" by auto
      }
      then show ?thesis by (intro sum.neutral, auto)
    qed
  also have "sum ?f {..degree p} = sum ?f {..<degree p} + ?f (degree p)"
    by(fold lessThan_Suc_atMost, unfold sum.lessThan_Suc, auto)
  also have "sum ?f {..<degree p} = 0"
    proof-
      {fix x assume "x < degree p"
        then have "coeff q (?r - x) = 0" by (intro coeff_eq_0, auto)
        then have "?f x = 0" by auto
      }
      then show ?thesis by (intro sum.neutral, auto)
    qed
  finally show "(i?r. ?f i)  0" using assms by (auto simp:)
qed

lemma degree_mult_eq_left_unit:
  fixes p q :: "'a :: comm_semiring_1 poly"
  assumes unit: "lead_coeff p dvd 1" and q0: "q  0"
  shows "degree (p * q) = degree p + degree q"
proof(intro degree_mult_eq2 notI)
  from unit obtain c where "lead_coeff p * c = 1" by (elim dvdE,auto)
  then have "c * lead_coeff p = 1" by (auto simp: ac_simps)
  moreover assume "lead_coeff p * lead_coeff q = 0"
    then have "c * lead_coeff p * lead_coeff q = 0" by (auto simp: ac_simps)
  ultimately have "lead_coeff q = 0" by auto
  with q0 show False by auto
qed

context ring_hom begin
lemma monic_degree_map_poly_hom: "monic p  degree (map_poly hom p) = degree p"
  by (auto intro: degree_map_poly)

lemma monic_map_poly_hom: "monic p  monic (map_poly hom p)"
  by (simp add: monic_degree_map_poly_hom)

end

lemma of_nat_zero:
  assumes "CARD('a::nontriv) dvd n"
  shows "(of_nat n :: 'a mod_ring) = 0"
  apply (transfer fixing: n) using assms by (presburger)

abbreviation rebase :: "'a :: nontriv mod_ring  'b :: nontriv mod_ring "("@_" [100]100)
  where "@x  of_int (to_int_mod_ring x)"

abbreviation rebase_poly :: "'a :: nontriv mod_ring poly  'b :: nontriv mod_ring poly" ("#_" [100]100)
  where "#x  of_int_poly (to_int_poly x)"

lemma rebase_self [simp]:
  "@x = x"
  by (simp add: of_int_of_int_mod_ring)

lemma map_poly_rebase [simp]:
  "map_poly rebase p = #p"
  by (induct p) simp_all

lemma rebase_poly_0: "#0 = 0"
  by simp

lemma rebase_poly_1: "#1 = 1"
  by simp

lemma rebase_poly_pCons[simp]: "#pCons a p = pCons (@a) (#p)"
by(cases "a = 0  p = 0", simp, fold map_poly_rebase, subst map_poly_pCons, auto)

lemma rebase_poly_self[simp]: "#p = p" by (induct p, auto)

lemma degree_rebase_poly_le: "degree (#p)  degree p"
  by (fold map_poly_rebase, subst degree_map_poly_le, auto)

lemma(in comm_ring_hom) degree_map_poly_unit: assumes "lead_coeff p dvd 1"
  shows "degree (map_poly hom p) = degree p"
  using hom_dvd_1[OF assms] by (auto intro: degree_map_poly)

lemma rebase_poly_eq_0_iff:
  "(#p :: 'a :: nontriv mod_ring poly) = 0  (i. (@coeff p i :: 'a mod_ring) = 0)" (is "?l  ?r")
proof(intro iffI)
  assume ?l
  then have "coeff (#p :: 'a mod_ring poly) i = 0" for i by auto
  then show ?r by auto
next
  assume ?r
  then have "coeff (#p :: 'a mod_ring poly) i = 0" for i by auto
  then show ?l by (intro poly_eqI, auto)
qed

lemma mod_mod_le:
  assumes ab: "(a::int)  b" and a0: "0 < a" and c0: "c  0" shows "(c mod a) mod b = c mod a"
  by (meson Divides.pos_mod_bound Divides.pos_mod_sign a0 ab less_le_trans mod_pos_pos_trivial)

locale rebase_ge =
  fixes ty1 :: "'a :: nontriv itself" and ty2 :: "'b :: nontriv itself"
  assumes card: "CARD('a)  CARD('b)"
begin

lemma ab: "int CARD('a)  CARD('b)" using card by auto

lemma rebase_eq_0[simp]:
  shows "(@(x :: 'a mod_ring) :: 'b mod_ring) = 0  x = 0"
  using card by (transfer, auto)

lemma degree_rebase_poly_eq[simp]:
  shows "degree (#(p :: 'a mod_ring poly) :: 'b mod_ring poly) = degree p"
  by (subst degree_map_poly; simp)

lemma lead_coeff_rebase_poly[simp]:
  "lead_coeff (#(p::'a mod_ring poly) :: 'b mod_ring poly) = @lead_coeff p"
  by simp

lemma to_int_mod_ring_rebase: "to_int_mod_ring(@(x :: 'a mod_ring)::'b mod_ring) = to_int_mod_ring x"
  using card by (transfer, auto)

lemma rebase_id[simp]: "@(@(x::'a mod_ring) :: 'b mod_ring) = @x"
  using card by (transfer, auto)

lemma rebase_poly_id[simp]: "#(#(p::'a mod_ring poly) :: 'b mod_ring poly) = #p" by (induct p, auto)

end

locale rebase_dvd =
  fixes ty1 :: "'a :: nontriv itself" and ty2 :: "'b :: nontriv itself"
  assumes dvd: "CARD('b) dvd CARD('a)"
begin

lemma ab: "CARD('a)  CARD('b)" by (rule dvd_imp_le[OF dvd], auto)

lemma rebase_id[simp]: "@(@(x::'b mod_ring) :: 'a mod_ring) = x" using ab by (transfer, auto)

lemma rebase_poly_id[simp]: "#(#(p::'b mod_ring poly) :: 'a mod_ring poly) = p" by (induct p, auto)


lemma rebase_of_nat[simp]: "(@(of_nat n :: 'a mod_ring) :: 'b mod_ring) = of_nat n"
  apply transfer apply (rule mod_mod_cancel) using dvd by presburger

lemma mod_1_lift_nat:
  assumes "(of_int (int x) :: 'a mod_ring) = 1"
  shows "(of_int (int x) :: 'b mod_ring) = 1"
proof -
  from assms have "int x mod CARD('a) = 1"
    by transfer
  then have "x mod CARD('a) = 1"
    by (simp add: of_nat_mod [symmetric])
  then have "x mod CARD('b) = 1"
    by (metis dvd mod_mod_cancel one_mod_card)
  then have "int x mod CARD('b) = 1"
    by (simp add: of_nat_mod [symmetric])
  then show ?thesis
    by transfer
qed

sublocale comm_ring_hom "rebase :: 'a mod_ring  'b mod_ring"
proof
  fix x y :: "'a mod_ring"
  show hom_add: "(@(x+y) :: 'b mod_ring) = @x + @y"
    by transfer (simp add: mod_simps dvd mod_mod_cancel)
  show "(@(x*y) :: 'b mod_ring) = @x * @y"
    by transfer (simp add: mod_simps dvd mod_mod_cancel)
qed auto

lemma of_nat_CARD_eq_0[simp]: "(of_nat CARD('a) :: 'b mod_ring) = 0"
  using dvd by (transfer, presburger)

interpretation map_poly_hom: map_poly_comm_ring_hom "rebase :: 'a mod_ring  'b mod_ring"..

sublocale poly: comm_ring_hom "rebase_poly :: 'a mod_ring poly  'b mod_ring poly"
  by (fold map_poly_rebase, unfold_locales)

lemma poly_rebase[simp]: "@poly p x = poly (#(p :: 'a mod_ring poly) :: 'b mod_ring poly) (@(x::'a mod_ring) :: 'b mod_ring)"
  by (fold map_poly_rebase poly_map_poly, rule)

lemma rebase_poly_smult[simp]: "(#(smult a p :: 'a mod_ring poly) :: 'b mod_ring poly) = smult (@a) (#p)"
  by(induct p, auto simp: hom_distribs)

end

locale rebase_mult =
  fixes ty1 :: "'a :: nontriv itself"
    and ty2 :: "'b :: nontriv itself"
    and ty3 :: "'d :: nontriv itself" (* due to some type reason, 'd has to be nontriv. *)
  assumes d: "CARD('a) = CARD('b) * CARD('d)"
begin

sublocale rebase_dvd ty1 ty2 using d by (unfold_locales, auto)

lemma rebase_mult_eq[simp]: "(of_nat CARD('d) * a :: 'a mod_ring) = of_nat CARD('d) * a'  (@a :: 'b mod_ring) = @a'"
proof-
  from dvd obtain d' where "CARD('a) = d' * CARD('b)" by (elim dvdE, auto)
  then show ?thesis by (transfer, auto simp:d)
qed

lemma rebase_poly_smult_eq[simp]:
  fixes a a' :: "'a mod_ring poly"
  defines "d  of_nat CARD('d) :: 'a mod_ring"
  shows "smult d a = smult d a'  (#a :: 'b mod_ring poly) = #a'" (is "?l  ?r")
proof (intro iffI)
  assume l: ?l show "?r"
  proof (intro poly_eqI)
    fix n
    from l have "coeff (smult d a) n = coeff (smult d a') n" by auto
    then have "d * coeff a n = d * coeff a' n" by auto
    from this[unfolded d_def rebase_mult_eq]
    show "coeff (#a :: 'b mod_ring poly) n = coeff (#a') n" by auto
  qed
next
  assume r: ?r show ?l
  proof(intro poly_eqI)
    fix n
    from r have "coeff (#a :: 'b mod_ring poly) n = coeff (#a') n" by auto
    then have "(@coeff a n :: 'b mod_ring) = @coeff a' n" by auto
    from this[folded d_def rebase_mult_eq]
    show "coeff (smult d a) n = coeff (smult d a') n" by auto
  qed
qed

lemma rebase_eq_0_imp_ex_mult:
  "(@(a :: 'a mod_ring) :: 'b mod_ring) = 0  (c :: 'd mod_ring. a = of_nat CARD('b) * @c)" (is "?l  ?r")
proof(cases "CARD('a) = CARD('b)")
  case True then show "?l  ?r"
    by (transfer, auto)
next
  case False
  have [simp]: "int CARD('b) mod int CARD('a) = int CARD('b)"
    by(rule mod_pos_pos_trivial, insert ab False, auto)
  {
    fix a
    assume a: "0  a" "a < int CARD('a)" and mod: "a mod int CARD('b) = 0"
    from mod have "int CARD('b) dvd a" by auto
    then obtain i where *: "a = int CARD('b) * i" by (elim dvdE, auto)
    from * a have "i < int CARD('d)" by (simp add:d)
    moreover
      hence "(i mod int CARD('a)) = i"
        by (metis dual_order.order_iff_strict less_le_trans not_le of_nat_less_iff "*" a(1) a(2)
             mod_pos_pos_trivial mult_less_cancel_right1 nat_neq_iff nontriv of_nat_1)
      with * a have "a = int CARD('b) * (i mod int CARD('a)) mod int CARD('a)"
        by (auto simp:d)
    moreover from * a have "0  i"
      using linordered_semiring_strict_class.mult_pos_neg of_nat_0_less_iff zero_less_card_finite
      by (simp add: zero_le_mult_iff)
    ultimately have "i0. i < int CARD('d)  a = int CARD('b) * (i mod int CARD('a)) mod int CARD('a)"
      by (auto intro: exI[of _ i])
  }
  then show "?l  ?r" by (transfer, auto simp:d)
qed

lemma rebase_poly_eq_0_imp_ex_smult:
  "(#(p :: 'a mod_ring poly) :: 'b mod_ring poly) = 0 
   (p' :: 'd mod_ring poly. (p = 0  p' = 0)  degree p'  degree p  p = smult (of_nat CARD('b)) (#p'))"
  (is "?l  ?r")
proof(induct p)
  case 0
  then show ?case by (intro exI[of _ 0],auto)
next
  case IH: (pCons a p)
  from IH(3) have "(#p :: 'b mod_ring poly) = 0" by auto
  from IH(2)[OF this] obtain p' :: "'d mod_ring poly"
  where *: "p = 0  p' = 0" "degree p'  degree p" "p = smult (of_nat CARD('b)) (#p')" by (elim exE conjE)
  from IH have "(@a :: 'b mod_ring) = 0" by auto
  from rebase_eq_0_imp_ex_mult[OF this]
  obtain a' :: "'d mod_ring" where a': "of_nat CARD('b) * (@a') = a" by auto
  from IH(1) have "pCons a p  0" by auto
  moreover from *(1,2) have "degree (pCons a' p')  degree (pCons a p)" by auto
  moreover from a' *(3)
  have "pCons a p = smult (of_nat CARD('b)) (#pCons a' p')" by auto
  ultimately show ?case by (intro exI[of _ "pCons a' p'"], auto)
qed

end



lemma mod_mod_nat[simp]: "a mod b mod (b * c :: nat) = a mod b" by (simp add: Divides.mod_mult2_eq)

locale Knuth_ex_4_6_2_22_base =
  fixes ty_p :: "'p :: nontriv itself"
    and ty_q :: "'q :: nontriv itself"
    and ty_pq :: "'pq :: nontriv itself"
  assumes pq: "CARD('pq) = CARD('p) * CARD('q)"
    and p_dvd_q: "CARD('p) dvd CARD('q)"
begin

sublocale rebase_q_to_p: rebase_dvd "TYPE('q)" "TYPE('p)" using p_dvd_q by (unfold_locales, auto)
sublocale rebase_pq_to_p: rebase_mult "TYPE('pq)" "TYPE('p)" "TYPE('q)" using pq by (unfold_locales, auto)
sublocale rebase_pq_to_q: rebase_mult "TYPE('pq)" "TYPE('q)" "TYPE('p)" using pq by (unfold_locales, auto)

sublocale rebase_p_to_q: rebase_ge "TYPE('p)" "TYPE ('q)" by (unfold_locales, insert p_dvd_q, simp add: dvd_imp_le)
sublocale rebase_p_to_pq: rebase_ge "TYPE('p)" "TYPE ('pq)" by (unfold_locales, simp add: pq)
sublocale rebase_q_to_pq: rebase_ge "TYPE('q)" "TYPE ('pq)" by (unfold_locales, simp add: pq)


(* TODO: needs ugly workaround to fix 'p... *)
definition "p  if (ty_p :: 'p itself) = ty_p then CARD('p) else undefined"
lemma p[simp]: "p  CARD('p)" unfolding p_def by auto

definition "q  if (ty_q :: 'q itself) = ty_q then CARD('q) else undefined"
lemma q[simp]: "q = CARD('q)" unfolding q_def by auto

lemma p1: "int p > 1"
  using nontriv [where ?'a = 'p] p by simp
lemma q1: "int q > 1"
  using nontriv [where ?'a = 'q] q by simp
lemma q0: "int q > 0"
  using q1 by auto

lemma pq2[simp]: "CARD('pq) = p * q" using pq by simp

lemma qq_eq_0[simp]: "(of_nat CARD('q) * of_nat CARD('q) :: 'pq mod_ring) = 0"
proof-
  have "(of_nat (q * q) :: 'pq mod_ring) = 0" by (rule of_nat_zero, auto simp: p_dvd_q)
  then show ?thesis by auto
qed

lemma of_nat_q[simp]: "of_nat q :: 'q mod_ring  0" by (fold of_nat_card_eq_0, auto)

lemma rebase_rebase[simp]: "(@(@(x::'pq mod_ring) :: 'q mod_ring) :: 'p mod_ring) = @x"
  using p_dvd_q by (transfer) (simp add: mod_mod_cancel)

lemma rebase_rebase_poly[simp]: "(#(#(f::'pq mod_ring poly) :: 'q mod_ring poly) :: 'p mod_ring poly) = #f"
  by (induct f, auto)

end

definition dupe_monic where
  "dupe_monic D H S T U = (case pdivmod_monic (T * U) D of (q,r)  (S * U + H * q, r))"

lemma dupe_monic:
  fixes D :: "'a :: prime_card mod_ring poly"
  assumes 1: "D*S + H*T = 1"
  and mon: "monic D"
  and dupe: "dupe_monic D H S T U = (A,B)" 
  shows "A * D + B * H = U" "B = 0  degree B < degree D"
    "coprime D H  A' * D + B' * H = U  B' = 0  degree B' < degree D  A' = A  B' = B"
proof -
  obtain q r where div: "pdivmod_monic (T * U) D = (q,r)" by force
  from dupe[unfolded dupe_monic_def div split]
  have A: "A = (S * U + H * q)" and B: "B = r" by auto
  from pdivmod_monic[OF mon div] have TU: "T * U = D * q + r" and 
    deg: "r = 0  degree r < degree D" by auto
  hence r: "r = T * U - D * q" by simp
  have "A * D + B * H = (S * U + H * q) * D + (T * U - D * q) * H" unfolding A B r by simp
  also have "... = (D * S + H * T) * U" by (simp add: field_simps)
  also have "D * S + H * T = 1" using 1 by simp  
  finally show eq: "A * D + B * H = U" by simp
  show degB: "B = 0  degree B < degree D" using deg unfolding B by (cases "r = 0", auto)
  assume another: "A' * D + B' * H = U" and degB': "B' = 0  degree B' < degree D" 
    and cop: "coprime D H"
  from degB have degB: "B = 0  degree B < degree D" by auto
  from degB' have degB': "B' = 0  degree B' < degree D" by auto
  from mon have D0: "D  0" by auto
  from another eq have "A' * D + B' * H = A * D + B * H" by simp
  from uniqueness_poly_equality[OF cop degB' degB D0 this]
  show "A' = A  B' = B" by auto
qed


locale Knuth_ex_4_6_2_22_main = Knuth_ex_4_6_2_22_base p_ty q_ty pq_ty
  for p_ty :: "'p::nontriv itself"
  and q_ty :: "'q::nontriv itself"
  and pq_ty :: "'pq::nontriv itself" +
  fixes a b :: "'p mod_ring poly" and u :: "'pq mod_ring poly" and v w :: "'q mod_ring poly"
  assumes uvw: "(#u :: 'q mod_ring poly) = v * w"
      and degu: "degree u = degree v + degree w" (* not in Knuth's book *)
      and avbw: "(a * #v + b * #w :: 'p mod_ring poly) = 1"
      and monic_v: "monic v" (* stronger than Knuth's *)
(* not needed!
      and aw: "degree a < degree w" *)
      and bv: "degree b < degree v"
begin

lemma deg_v: "degree (#v :: 'p mod_ring poly) = degree v"
  using monic_v by (simp add: of_int_hom.monic_degree_map_poly_hom)

lemma u0: "u  0" using degu bv by auto

lemma ex_f: "f :: 'p mod_ring poly. u = #v * #w + smult (of_nat q) (#f)"
proof-
  from uvw have "(#(u - #v * #w) :: 'q mod_ring poly) = 0" by (auto simp:hom_distribs)
  from rebase_pq_to_q.rebase_poly_eq_0_imp_ex_smult[OF this]
  obtain f :: "'p mod_ring poly" where "u - #v * #w = smult (of_nat q) (#f)" by force
  then have "u = #v * #w + smult (of_nat q) (#f)" by (metis add_diff_cancel_left' add_diff_eq)
  then show ?thesis by (intro exI[of _ f], auto)
qed

definition "f :: 'p mod_ring poly  SOME f. u = #v * #w + smult (of_nat q) (#f)"

lemma u: "u = #v * #w + smult (of_nat q) (#f)"
  using ex_f[folded some_eq_ex] f_def by auto

lemma t_ex: "t :: 'p mod_ring poly. degree (b * f - t * #v) < degree v"
proof-
  define v' where "v'  #v :: 'p mod_ring poly"
  from monic_v
  have 1: "lead_coeff v' = 1" by (simp add: v'_def deg_v)
  then have 4: "v'  0" by auto
  obtain t rem :: "'p mod_ring poly"
  where "pseudo_divmod (b * f) v' = (t,rem)" by force
  from pseudo_divmod[OF 4 this, folded, unfolded 1]
  have "b * f = v' * t + rem" and deg: "rem = 0  degree rem < degree v'" by auto
  then have "rem = b * f - t * v'" by(auto simp: ac_simps)
  also have "... = b * f - #(#t :: 'p mod_ring poly) * v'" (is "_ = _ - ?t * v'") by simp
  also have "... = b * f - ?t * #v"
    by (unfold v'_def, rule)
  finally have "degree rem = degree ..." by auto
  with deg bv have "degree (b * f - ?t * #v :: 'p mod_ring poly) < degree v" by (auto simp: v'_def deg_v)
  then show ?thesis by (rule exI)
qed

definition t where "t  SOME t :: 'p mod_ring poly. degree (b * f - t * #v) < degree v"

definition "v'  b * f - t * #v"
definition "w'  a * f + t * #w"

lemma f: "w' * #v + v' * #w = f" (is "?l = _")
proof-
  have "?l = f * (a * #v + b * #w :: 'p mod_ring poly)" by (simp add: v'_def w'_def ring_distribs ac_simps)
  also
    from avbw have "(#(a * #v + b * #w) :: 'p mod_ring poly) = 1" by auto
    then have "(a * #v + b * #w :: 'p mod_ring poly) = 1" by auto
  finally show ?thesis by auto
qed

lemma degv': "degree v' < degree v" by (unfold v'_def t_def, rule someI_ex, rule t_ex)

lemma degqf[simp]: "degree (smult (of_nat CARD('q)) (#f :: 'pq mod_ring poly)) = degree (#f :: 'pq mod_ring poly)"
proof (intro degree_smult_eqI)
  assume "degree (#f :: 'pq mod_ring poly)  0"
  then have f0: "degree f  0" by simp
  moreover define l where "l  lead_coeff f"
  ultimately have l0: "l  0" by auto
  then show "of_nat CARD('q) * lead_coeff (#f::'pq mod_ring poly)  0"
  apply (unfold rebase_p_to_pq.lead_coeff_rebase_poly, fold l_def)
  apply (transfer)
  using q1 by (simp add: pq mod_mod_cancel)
qed

lemma degw': "degree w'  degree w"
proof(rule ccontr)
  let ?f = "#f :: 'pq mod_ring poly"
  let ?qf = "smult (of_nat q) (#f) :: 'pq mod_ring poly"

  have "degree (#w::'p mod_ring poly)  degree w" by (rule degree_rebase_poly_le)
  also assume "¬ degree w'  degree w"
  then have 1: "degree w < degree w'" by auto
  finally have 2: "degree (#w :: 'p mod_ring poly) < degree w'" by auto
  then have w'0: "w'  0" by auto

  have 3: "degree (#v * w') = degree (#v :: 'p mod_ring poly) + degree w'"
      using monic_v[unfolded] by (intro degree_monic_mult[OF _ w'0], auto simp: deg_v)

  have "degree f  degree u"
  proof(rule ccontr)
    assume "¬?thesis"
    then have *: "degree u < degree f" by auto
    with degu have 1: "degree v + degree w < degree f" by auto
    define lcf where "lcf  lead_coeff f"
    with 1 have lcf0: "lcf  0" by (unfold, auto)
    have "degree f = degree ?qf" by simp
    also have "... = degree (#v * #w + ?qf)"
    proof(rule sym, rule degree_add_eq_right)
      from 1 degree_mult_le[of "#v::'pq mod_ring poly" "#w"]
      show "degree (#v * #w :: 'pq mod_ring poly) < degree ?qf" by simp
    qed
    also have "... < degree f" using * u by auto
    finally show "False" by auto
  qed
  with degu have "degree f  degree v + degree w" by auto
  also note f[symmetric]
  finally have "degree (w' * #v + v' * #w)  degree v + degree w".
  moreover have "degree (w' * #v + v' * #w) = degree (w' * #v)"
  proof(rule degree_add_eq_left)
    have "degree (v' * #w)  degree v' + degree (#w :: 'p mod_ring poly)"
      by(rule degree_mult_le)
    also have "... < degree v + degree (#w :: 'p mod_ring poly)" using degv' by auto
    also have "... < degree (#v :: 'p mod_ring poly) + degree w'" using 2 by (auto simp: deg_v)
    also have "... = degree (#v * w')" using 3 by auto
    finally show "degree (v' * #w) < degree (w' * #v)" by (auto simp: ac_simps)
  qed
  ultimately have "degree (w' * #v)  degree v + degree w" by auto
  moreover
    from 3 have "degree (w' * #v) = degree w' + degree v" by (auto simp: ac_simps deg_v)
    with 1 have "degree w + degree v < degree (w' * #v)" by auto
  ultimately show False by auto
qed

abbreviation "qv'  smult (of_nat q) (#v') :: 'pq mod_ring poly"
abbreviation "qw'  smult (of_nat q) (#w') :: 'pq mod_ring poly"

abbreviation "V  #v + qv'"
abbreviation "W  #w + qw'"

lemma vV: "v = #V" by (auto simp: v'_def hom_distribs)

lemma wW: "w = #W" by (auto simp: w'_def hom_distribs)

lemma uVW: "u = V * W"
  by (subst u, fold f, simp add: ring_distribs add.left_cancel smult_add_right[symmetric] hom_distribs)

lemma degV: "degree V = degree v"
  and lcV: "lead_coeff V = @lead_coeff v"
  and degW: "degree W = degree w"
proof-
  from p1 q1 have "int p < int p * int q" by auto
  from less_trans[OF _ this]
  have 1: "l < int p  l < int p * int q" for l by auto
  have "degree qv' = degree (#v' :: 'pq mod_ring poly)"
  proof (rule degree_smult_eqI, safe, unfold rebase_p_to_pq.degree_rebase_poly_eq)
    define l where "l  lead_coeff v'"
    assume "degree v' > 0"
    then have "lead_coeff v'  0" by auto
    then have "(@l :: 'pq mod_ring)  0" by (simp add: l_def)
    then have "(of_nat q * @l :: 'pq mod_ring)  0"
      apply (transfer fixing:q_ty) using p_dvd_q p1 q1 1 by auto
    moreover assume " of_nat q * coeff (#v') (degree v') = (0 :: 'pq mod_ring)"
    ultimately show False by (auto simp: l_def)
  qed
  also from degv' have "... < degree (#v::'pq mod_ring poly)" by simp
  finally have *: "degree qv' < degree (#v :: 'pq mod_ring poly)".
  from degree_add_eq_left[OF *]
  show **: "degree V = degree v" by (simp add: v'_def)

  from * have "coeff qv' (degree v) = 0" by (intro coeff_eq_0, auto)
  then show "lead_coeff V = @lead_coeff v" by (unfold **, auto simp: v'_def)

  with u0 uVW have "degree (V * W) = degree V + degree W"
    by (intro degree_mult_eq_left_unit, auto simp: monic_v)
  from this[folded uVW, unfolded degu **] show "degree W = degree w" by auto
qed

end

locale Knuth_ex_4_6_2_22_prime = Knuth_ex_4_6_2_22_main ty_p ty_q ty_pq a b u v w
  for ty_p :: "'p :: prime_card itself"
  and ty_q :: "'q :: nontriv itself"
  and ty_pq :: "'pq :: nontriv itself"
  and a b u v w +
  assumes coprime: "coprime (#v :: 'p mod_ring poly) (#w)" (* not in Knuth *)

begin

lemma coprime_preserves: "coprime (#V :: 'p mod_ring poly) (#W)"
  apply (intro coprimeI,simp add: rebase_q_to_p.of_nat_CARD_eq_0[simplified] hom_distribs)
  using coprime by (elim coprimeE, auto)

lemma pre_unique:
  assumes f2: "w'' * #v + v'' * #w = f"
      and degv'': "degree v'' < degree v"
  shows "v'' = v'  w'' = w'"
proof(intro conjI)
  from f f2
  have "w' * #v + v' * #w = w'' * #v + v'' * #w" by auto
  also have "... - w'' * #v = v'' * #w" by auto
  also have "... - v' * #w = (v''- v') * #w" by (auto simp: left_diff_distrib)
  finally have *: "(w' - w'') * #v = (v''- v') * #w" by (auto simp: left_diff_distrib)
  then have "#v dvd (v'' - v') * #w" by (auto intro: dvdI[of _ _ "w' - w''"] simp: ac_simps)
  with coprime have "#v dvd v'' - v'"
    by (simp add: coprime_dvd_mult_left_iff)
  moreover have "degree (v'' - v') < degree v" by (rule degree_diff_less[OF degv'' degv'])
  ultimately have "v'' - v' = 0"
    by (metis deg_v degree_0 gr_implies_not_zero poly_divides_conv0)
  then show "v'' = v'" by auto
  with * have "(w' - w'') * #v = 0" by auto
  with bv have "w' - w'' = 0"
    by (metis deg_v degree_0 gr_implies_not_zero mult_eq_0_iff)
  then show "w'' = w'" by auto
qed

lemma unique:
  assumes vV2: "v = #V2" and wW2: "w = #W2" and uVW2: "u = V2 * W2"
      and degV2: "degree V2 = degree v" and degW2: "degree W2 = degree w"
      and lc: "lead_coeff V2 = @lead_coeff v"
  shows "V2 = V" "W2 = W"
proof-
  from vV2 have "(#(V2 - #v) :: 'q mod_ring poly) = 0" by (auto simp: hom_distribs)
  from rebase_pq_to_q.rebase_poly_eq_0_imp_ex_smult[OF this]
  obtain v'' :: "'p mod_ring poly"
  where deg: "degree v''  degree (V2 - #v)"
    and v'': "V2 - #v = smult (of_nat CARD('q)) (#v'')" by (elim exE conjE)
  then have V2: "V2 = #v + ..." by (metis add_diff_cancel_left' diff_add_cancel)

  from lc[unfolded degV2, unfolded V2]
  have "of_nat q * (@coeff v'' (degree v) :: 'pq mod_ring) = of_nat q * 0" by auto
  from this[unfolded q rebase_pq_to_p.rebase_mult_eq]
  have "coeff v'' (degree v) = 0" by simp
  moreover have "degree v''   degree v" using deg degV2
    by (metis degree_diff_le le_antisym nat_le_linear rebase_q_to_pq.degree_rebase_poly_eq)
  ultimately have degv'': "degree v'' < degree v"
    using bv eq_zero_or_degree_less by fastforce

  from wW2 have "(#(W2 - #w) :: 'q mod_ring poly) = 0" by (auto simp: hom_distribs)
  from rebase_pq_to_q.rebase_poly_eq_0_imp_ex_smult[OF this] pq
  obtain w'' :: "'p mod_ring poly" where w'': "W2 - #w = smult (of_nat q) (#w'')" by force
  then have W2: "W2 = #w + ..." by (metis add_diff_cancel_left' diff_add_cancel)

  have "u = #v * #w + smult (of_nat q) (#w'' * #v + #v'' * #w) + smult (of_nat (q * q)) (#v'' * #w'')"
    by(simp add: uVW2 V2 W2 ring_distribs smult_add_right ac_simps)
  also have "smult (of_nat (q * q)) (#v'' * #w'' :: 'pq mod_ring poly) = 0" by simp
  finally have "u - #v * #w = smult (of_nat q) (#w'' * #v + #v'' * #w)" by auto
  also have "u - #v * #w = smult (of_nat q) (#f)" by (subst u, simp)
  finally have "w'' * #v + v'' * #w = f" by (simp add: hom_distribs)
  from pre_unique[OF this degv'']
  have pre: "v'' = v'" "w'' = w'" by auto
  with V2 W2 show "V2 = V" "W2 = W" by auto
qed

end

definition
  "hensel_1 (ty ::'p :: prime_card itself)
    (u :: 'pq :: nontriv mod_ring poly) (v :: 'q :: nontriv mod_ring poly) (w :: 'q mod_ring poly) 
   if v = 1 then (1,u) else
   let (s, t) = bezout_coefficients (#v :: 'p mod_ring poly) (#w) in
   let (a, b) = dupe_monic (#v::'p mod_ring poly) (#w) s t 1 in
   (Knuth_ex_4_6_2_22_main.V TYPE('q) b u v w, Knuth_ex_4_6_2_22_main.W TYPE('q) a b u v w)"

lemma hensel_1:
  fixes u :: "'pq :: nontriv mod_ring poly"
    and v w :: "'q :: nontriv mod_ring poly"
  assumes "CARD('pq) = CARD('p :: prime_card) * CARD('q)"
      and "CARD('p) dvd CARD('q)"
      and uvw: "#u = v * w"
      and degu: "degree u = degree v + degree w"
      and monic: "monic v"
      and coprime: "coprime (#v :: 'p mod_ring poly) (#w)"
      and out: "hensel_1 TYPE('p) u v w = (V',W')"
  shows "u = V' * W'  v = #V'  w = #W'  degree V' = degree v  degree W' = degree w 
         monic V'  coprime (#V' :: 'p mod_ring poly) (#W')" (is ?main)
    and "(V'' W''. u = V'' * W''  v = #V''  w = #W'' 
          degree V'' = degree v  degree W'' = degree w  lead_coeff V'' = @lead_coeff v 
          V'' = V'  W'' = W')" (is "?unique")
proof-
  from monic
  have degv: "degree (#v :: 'p mod_ring poly) = degree v"
    by (simp add: of_int_hom.monic_degree_map_poly_hom)
  from monic
  have monic2: "monic (#v :: 'p mod_ring poly)"
    by (auto simp: degv)
  obtain s t where bezout: "bezout_coefficients (#v :: 'p mod_ring poly) (#w) = (s, t)"
    by (auto simp add: prod_eq_iff)
  then have "s * #v + t * #w = gcd (#v :: 'p mod_ring poly) (#w)"
    by (rule bezout_coefficients)
  with coprime have vswt: "#v * s + #w * t = 1"
    by (simp add: ac_simps)
  obtain a b where dupe: "dupe_monic (#v) (#w) s t 1 = (a, b)" by force
  from dupe_monic(1,2)[OF vswt monic2, where U=1, unfolded this]
  have avbw: "a * #v + b * #w = 1" and degb: "b = 0  degree b < degree (#v::'p mod_ring poly)" by auto
  have "?main  ?unique"
  proof (cases "b = 0")
    case b0: True
    with avbw have "a * #v = 1" by auto
    then have "degree (#v :: 'p mod_ring poly) = 0"
      by (metis degree_1 degree_mult_eq_0 mult_zero_left one_neq_zero)
    from this[unfolded degv] monic_degree_0[OF monic[unfolded]]
    have 1: "v = 1" by auto
    with b0 out uvw have 2: "V' = 1" "W' = u"
      by (unfold split hensel_1_def Let_def dupe) auto
    have 3: ?unique apply (simp add: 1 2) by (metis monic_degree_0 mult.left_neutral)
    with uvw degu show ?thesis unfolding 1 2 by auto
  next
    case b0: False
    with degb degv have degb: "degree b < degree v" by auto
    then have v1: "v  1" by auto
    interpret Knuth_ex_4_6_2_22_prime "TYPE('p)" "TYPE('q)" "TYPE('pq)" a b
      by (unfold_locales; fact assms degb avbw)
    show ?thesis
    proof (intro conjI)
      from out [unfolded hensel_1_def] v1
      have 1 [simp]: "V' = V" "W' = W" by (auto simp: bezout dupe)
      from uVW show "u = V' * W'" by auto
      from degV show [simp]: "degree V' = degree v" by simp
      from degW show [simp]: "degree W' = degree w" by simp
      from lcV have "lead_coeff V' = @lead_coeff v" by simp
      with monic_v show "monic V'" by (simp add:)
      from vV show "v = #V'" by simp
      from wW show "w = #W'" by simp
      from coprime_preserves show "coprime (#V' :: 'p mod_ring poly) (#W')" by simp
      show 9: ?unique by (unfold 1, intro allI conjI impI; rule unique)
    qed
  qed
  then show ?main ?unique by (fact conjunct1, fact conjunct2)
qed

end

Theory Berlekamp_Hensel

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Result is Unique›

text ‹We combine the finite field factorization algorithm with Hensel-lifting to
  obtain factorizations mod $p^n$. Moreover, we prove results on unique-factorizations
  in mod $p^n$ which admit to extend the uniqueness result for binary Hensel-lifting
  to the general case. As a consequence, our factorization algorithm will produce
  unique factorizations mod $p^n$.› 

theory Berlekamp_Hensel
imports 
  Finite_Field_Factorization_Record_Based
  Hensel_Lifting
begin

hide_const coeff monom

definition berlekamp_hensel :: "int  nat  int poly  int poly list" where
  "berlekamp_hensel p n f = (case finite_field_factorization_int p f of
    (_,fs)  hensel_lifting p n f fs)"

text ‹Finite field factorization in combination with Hensel-lifting delivers 
  factorization modulo $p^k$ where factors are irreducible modulo $p$.
  Assumptions: input polynomial is square-free modulo $p$.›

context poly_mod_prime begin

lemma berlekamp_hensel_main:
  assumes n: "n  0"
    and res: "berlekamp_hensel p n f = gs" 
    and cop: "coprime (lead_coeff f) p" 
    and sf: "square_free_m f" 
    and berl: "finite_field_factorization_int p f = (c,fs)" 
  shows "poly_mod.factorization_m (p ^ n) f (lead_coeff f, mset gs) ― ‹factorization mod p^n›"
    and "sort (map degree fs) = sort (map degree gs)"
    and " g. g  set gs  monic g  poly_mod.Mp (p^n) g = g   ― ‹monic and normalized›
        poly_mod.irreducible_m p g  ― ‹irreducibility even mod p›
        poly_mod.degree_m p g = degree g  ― ‹mod p› does not change degree of g›"
proof -
  from res[unfolded berlekamp_hensel_def berl split] 
  have hen: "hensel_lifting p n f fs = gs" .
  note bh = finite_field_factorization_int[OF sf berl]
  from bh have "poly_mod.factorization_m p f (c, mset fs)" "c  {0..<p}" "(fiset fs. set (coeffs fi)  {0..<p})" 
    by (auto simp: poly_mod.unique_factorization_m_alt_def)
  note hen = hensel_lifting[OF n hen cop sf, OF this]
  show "poly_mod.factorization_m (p ^ n) f (lead_coeff f, mset gs)" 
    "sort (map degree fs) = sort (map degree gs)"
    " g. g  set gs  monic g  poly_mod.Mp (p^n) g = g   
      poly_mod.irreducible_m p g  
      poly_mod.degree_m p g = degree g" using hen by auto
qed

theorem berlekamp_hensel:
  assumes cop: "coprime (lead_coeff f) p"
    and sf: "square_free_m f"
    and res: "berlekamp_hensel p n f = gs"
    and n: "n  0"
  shows "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs) ― ‹factorization mod p^n›"
    and " g. g  set gs  poly_mod.Mp (p^n) g = g  poly_mod.irreducible_m p g
      ― ‹normalized and irreducible› even mod p›"
proof -
  obtain c fs where "finite_field_factorization_int p f = (c,fs)" by force
  from berlekamp_hensel_main[OF n res cop sf this]
  show "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs)" 
    " g. g  set gs  poly_mod.Mp (p^n) g = g  poly_mod.irreducible_m p g" by auto
qed

lemma berlekamp_and_hensel_separated:
  assumes cop: "coprime (lead_coeff f) p"
    and sf: "square_free_m f"
    and res: "hensel_lifting p n f fs = gs"
    and berl: "finite_field_factorization_int p f = (c,fs)"
    and n: "n  0"
  shows "berlekamp_hensel p n f = gs"
    and "sort (map degree fs) = sort (map degree gs)"
proof -
  show "berlekamp_hensel p n f = gs" unfolding res[symmetric]
    berlekamp_hensel_def hensel_lifting_def berl split Let_def ..
  from berlekamp_hensel_main[OF n this cop sf berl] show "sort (map degree fs) = sort (map degree gs)"
    by auto 
qed

end

lemma prime_cop_exp_poly_mod:
  assumes prime: "prime p" and cop: "coprime c p" and n: "n  0"
  shows "poly_mod.M (p^n) c  {1 ..< p^n}"
proof -
  from prime have p1: "p > 1" by (simp add: prime_int_iff)
  interpret poly_mod_2 "p^n" unfolding poly_mod_2_def using p1 n by simp
  from cop p1 m1 have "M c  0"
    by (auto simp add: M_def)
  moreover have "M c < p^n" "M c  0" unfolding M_def using m1 by auto
  ultimately show ?thesis by auto
qed

context poly_mod_2
begin

context
  fixes p :: int
  assumes prime: "prime p"
begin

interpretation p: poly_mod_prime p using prime by unfold_locales

lemma coprime_lead_coeff_factor: assumes "coprime (lead_coeff (f * g)) p"
  shows "coprime (lead_coeff f) p" "coprime (lead_coeff g) p" 
proof -
  {
    fix f g 
    assume cop: "coprime (lead_coeff (f * g)) p" 
    from this[unfolded lead_coeff_mult]
    have "coprime (lead_coeff f) p" using prime
      by simp
  }
  from this[OF assms] this[of g f] assms
  show "coprime (lead_coeff f) p" "coprime (lead_coeff g) p" by (auto simp: ac_simps)
qed

lemma unique_factorization_m_factor: assumes uf: "unique_factorization_m (f * g) (c,hs)"
  and cop: "coprime (lead_coeff (f * g)) p"  
  and sf: "p.square_free_m (f * g)" 
  and n: "n  0" 
  and m: "m = p^n" 
  shows " fs gs. unique_factorization_m f (lead_coeff f,fs) 
   unique_factorization_m g (lead_coeff g,gs) 
   Mf (c,hs) = Mf (lead_coeff f * lead_coeff g, fs + gs)
   image_mset Mp fs = fs  image_mset Mp gs = gs"
proof -
  from prime have p1: "1 < p" by (simp add: prime_int_iff)
  interpret p: poly_mod_2 p by (standard, rule p1)
  note sf = p.square_free_m_factor[OF sf]
  note cop = coprime_lead_coeff_factor[OF cop]
  from cop have copm: "coprime (lead_coeff f) m" "coprime (lead_coeff g) m" 
    by (simp_all add: m)
  have df: "degree_m f = degree f" 
    by (rule degree_m_eq[OF _ m1], insert copm(1) m1, auto)  
  have dg: "degree_m g = degree g" 
    by (rule degree_m_eq[OF _ m1], insert copm(2) m1, auto)  
  define fs where "fs  mset (berlekamp_hensel p n f)"
  define gs where "gs  mset (berlekamp_hensel p n g)"
  from p.berlekamp_hensel[OF cop(1) sf(1) refl n, folded m]
  have f: "factorization_m f (lead_coeff f,fs)" 
    and f_id: " f. f ∈# fs  Mp f = f" unfolding fs_def by auto
  from p.berlekamp_hensel[OF cop(2) sf(2) refl n, folded m]
  have g: "factorization_m g (lead_coeff g,gs)" 
    and g_id: " f. f ∈# gs  Mp f = f" unfolding gs_def by auto
  from factorization_m_prod[OF f g] uf[unfolded unique_factorization_m_alt_def]
  have eq: "Mf (lead_coeff f * lead_coeff g, fs + gs) = Mf (c,hs)" by blast
  have uff: "unique_factorization_m f (lead_coeff f,fs)" 
  proof (rule unique_factorization_mI[OF f])
    fix e ks
    assume "factorization_m f (e,ks)" 
    from factorization_m_prod[OF this g] uf[unfolded unique_factorization_m_alt_def]
      factorization_m_lead_coeff[OF this, unfolded degree_m_eq_lead_coeff[OF df]]
    have "Mf (e * lead_coeff g, ks + gs) = Mf (c,hs)" and e: "M (lead_coeff f) = M e" by blast+
    from this[folded eq, unfolded Mf_def split] 
    have ks: "image_mset Mp ks = image_mset Mp fs" by auto
    show "Mf (e, ks) = Mf (lead_coeff f, fs)" unfolding Mf_def split ks e by simp
  qed
  have idf: "image_mset Mp fs = fs" using f_id by (induct fs, auto)
  have idg: "image_mset Mp gs = gs" using g_id by (induct gs, auto)
  have ufg: "unique_factorization_m g (lead_coeff g,gs)" 
  proof (rule unique_factorization_mI[OF g])
    fix e ks
    assume "factorization_m g (e,ks)" 
    from factorization_m_prod[OF f this] uf[unfolded unique_factorization_m_alt_def]
      factorization_m_lead_coeff[OF this, unfolded degree_m_eq_lead_coeff[OF dg]]
    have "Mf (lead_coeff f * e, fs + ks) = Mf (c,hs)" and e: "M (lead_coeff g) = M e" by blast+
    from this[folded eq, unfolded Mf_def split] 
    have ks: "image_mset Mp ks = image_mset Mp gs" by auto
    show "Mf (e, ks) = Mf (lead_coeff g, gs)" unfolding Mf_def split ks e by simp
  qed
  from uff ufg eq[symmetric] idf idg show ?thesis by auto
qed

lemma unique_factorization_factorI:
  assumes ufact: "unique_factorization_m (f * g) FG"
    and cop: "coprime (lead_coeff (f * g)) p"
    and sf: "poly_mod.square_free_m p (f * g)"
    and n: "n  0" 
    and m: "m = p^n" 
  shows "factorization_m f F  unique_factorization_m f F"
    and "factorization_m g G  unique_factorization_m g G"
proof -
  obtain c fg where FG: "FG = (c,fg)" by force
  from unique_factorization_m_factor[OF ufact[unfolded FG] cop sf n m]
  obtain fs gs where ufact: "unique_factorization_m f (lead_coeff f, fs)" 
    "unique_factorization_m g (lead_coeff g, gs)" by auto
  from ufact(1) show "factorization_m f F  unique_factorization_m f F"
    by (metis unique_factorization_m_alt_def)
  from ufact(2) show "factorization_m g G  unique_factorization_m g G"
    by (metis unique_factorization_m_alt_def)
qed

end

lemma monic_Mp_prod_mset: assumes fs: " f. f ∈# fs  monic (Mp f)" 
  shows "monic (Mp (prod_mset fs))"
proof -
  have "monic (prod_mset (image_mset Mp fs))"
    by (rule monic_prod_mset, insert fs, auto)
  from monic_Mp[OF this] have "monic (Mp (prod_mset (image_mset Mp fs)))" .
  also have "Mp (prod_mset (image_mset Mp fs)) = Mp (prod_mset fs)" by (rule Mp_prod_mset)
  finally show ?thesis .
qed

lemma degree_Mp_mult_monic: assumes "monic f" "monic g"
  shows "degree (Mp (f * g)) = degree f + degree g"
  by (metis zero_neq_one assms degree_monic_mult leading_coeff_0_iff monic_degree_m monic_mult)
  
lemma factorization_m_degree: assumes "factorization_m f (c,fs)" 
  and 0: "Mp f  0" 
  shows "degree_m f = sum_mset (image_mset degree_m fs)" 
proof -
  note a = assms[unfolded factorization_m_def split] 
  hence deg: "degree_m f = degree_m (smult c (prod_mset fs))" 
    and fs: " f. f ∈# fs  monic (Mp f)" by auto
  define gs where "gs  Mp (prod_mset fs)" 
  from monic_Mp_prod_mset[OF fs] have mon_gs: "monic gs" unfolding gs_def .
  have d:"degree (Mp (Polynomial.smult c gs)) = degree gs"
  proof -
    have f1: "0  c" by (metis "0" Mp_0 a(1) smult_eq_0_iff)
    then have "M c  0" by (metis (no_types) "0" assms(1) factorization_m_lead_coeff leading_coeff_0_iff)
    then show "degree (Mp (Polynomial.smult c gs)) = degree gs"
      unfolding monic_degree_m[OF mon_gs,symmetric]
      using f1 by (metis coeff_smult degree_m_eq degree_smult_eq m1 mon_gs monic_degree_m mult_cancel_left1 poly_mod.M_def)
  qed
  note deg
  also have "degree_m (smult c (prod_mset fs)) = degree_m (smult c gs)"
    unfolding gs_def by simp
  also have " = degree gs" using d.
  also have " = sum_mset (image_mset degree_m fs)" unfolding gs_def
    using fs
  proof (induct fs)
    case (add f fs)
    have mon: "monic (Mp f)" "monic (Mp (prod_mset fs))" using monic_Mp_prod_mset[of fs]
      add(2) by auto
    have "degree (Mp (prod_mset (add_mset f fs))) = degree (Mp (Mp f * Mp (prod_mset fs)))" 
      by (auto simp: ac_simps)
    also have " = degree (Mp f) + degree (Mp (prod_mset fs))" 
      by (rule degree_Mp_mult_monic[OF mon])
    also have "degree (Mp (prod_mset fs)) = sum_mset (image_mset degree_m fs)" 
      by (rule add(1), insert add(2), auto)
    finally show ?case by (simp add: ac_simps)
  qed simp
  finally show ?thesis .
qed

lemma degree_m_mult_le: "degree_m (f * g)  degree_m f + degree_m g" 
  using degree_m_mult_le by auto

lemma degree_m_prod_mset_le: "degree_m (prod_mset fs)  sum_mset (image_mset degree_m fs)" 
proof (induct fs)
  case empty
  show ?case by simp
next
  case (add f fs)
  then show ?case using degree_m_mult_le[of f "prod_mset fs"] by auto
qed

end


context poly_mod_prime
begin

lemma unique_factorization_m_factor_partition: assumes l0: "l  0" 
  and uf: "poly_mod.unique_factorization_m (p^l) f (lead_coeff f, mset gs)" 
  and f: "f = f1 * f2" 
  and cop: "coprime (lead_coeff f) p" 
  and sf: "square_free_m f" 
  and part: "List.partition (λgi. gi dvdm f1) gs = (gs1, gs2)" 
shows "poly_mod.unique_factorization_m (p^l) f1 (lead_coeff f1, mset gs1)"
  "poly_mod.unique_factorization_m (p^l) f2 (lead_coeff f2, mset gs2)"
proof -
  interpret pl: poly_mod_2 "p^l" by (standard, insert m1 l0, auto)
  let ?I = "image_mset pl.Mp" 
  note Mp_pow [simp] = Mp_Mp_pow_is_Mp[OF l0 m1]
  have [simp]: "pl.Mp x dvdm u = (x dvdm u)" for x u unfolding dvdm_def using Mp_pow[of x]
    by (metis poly_mod.mult_Mp(1))
  have gs_split: "set gs = set gs1  set gs2" using part by auto
  from pl.unique_factorization_m_factor[OF prime uf[unfolded f] _ _ l0 refl, folded f, OF cop sf]
  obtain hs1 hs2 where uf': "pl.unique_factorization_m f1 (lead_coeff f1, hs1)" 
      "pl.unique_factorization_m f2 (lead_coeff f2, hs2)"
    and gs_hs: "?I (mset gs) = hs1 + hs2"
    unfolding pl.Mf_def split by auto
  have gs_gs: "?I (mset gs) = ?I (mset gs1) + ?I (mset gs2)" using part 
    by (auto, induct gs arbitrary: gs1 gs2, auto)
  with gs_hs have gs_hs12: "?I (mset gs1) + ?I (mset gs2) = hs1 + hs2" by auto
  note pl_dvdm_imp_p_dvdm = pl_dvdm_imp_p_dvdm[OF l0]
  note fact = pl.unique_factorization_m_imp_factorization[OF uf]
  have gs1: "?I (mset gs1) = {#x ∈# ?I (mset gs). x dvdm f1#}"
    using part by (auto, induct gs arbitrary: gs1 gs2, auto)
  also have " = {#x ∈# hs1. x dvdm f1#} + {#x ∈# hs2. x dvdm f1#}" unfolding gs_hs by simp
  also have "{#x ∈# hs2. x dvdm f1#} = {#}" 
  proof (rule ccontr)
    assume "¬ ?thesis" 
    then obtain x where x: "x ∈# hs2" and dvd: "x dvdm f1" by fastforce
    from x gs_hs have "x ∈# ?I (mset gs)" by auto
    with fact[unfolded pl.factorization_m_def]
    have xx: "pl.irreducibled_m x" "monic x" by auto
    from square_free_m_prod_imp_coprime_m[OF sf[unfolded f]] 
    have cop_h_f: "coprime_m f1 f2" by auto  
    from pl.factorization_m_mem_dvdm[OF pl.unique_factorization_m_imp_factorization[OF uf'(2)], of x] x 
    have "pl.dvdm x f2" by auto
    hence "x dvdm f2" by (rule pl_dvdm_imp_p_dvdm)
    from cop_h_f[unfolded coprime_m_def, rule_format, OF dvd this] 
    have "x dvdm 1" by auto
    from dvdm_imp_degree_le[OF this xx(2) _ m1] have "degree x = 0" by auto
    with xx show False unfolding pl.irreducibled_m_def by auto
  qed
  also have "{#x ∈# hs1. x dvdm f1#} = hs1"
  proof (rule ccontr)
    assume "¬ ?thesis" 
    from filter_mset_inequality[OF this]
    obtain x where x: "x ∈# hs1" and dvd: "¬ x dvdm f1" by blast
    from pl.factorization_m_mem_dvdm[OF pl.unique_factorization_m_imp_factorization[OF uf'(1)], 
      of x] x dvd 
    have "pl.dvdm x f1" by auto
    from pl_dvdm_imp_p_dvdm[OF this] dvd show False by auto
  qed
  finally have gs_hs1: "?I (mset gs1) = hs1" by simp
  with gs_hs12 have "?I (mset gs2) = hs2" by auto
  with uf' gs_hs1 have "pl.unique_factorization_m f1 (lead_coeff f1, ?I (mset gs1))"
     "pl.unique_factorization_m f2 (lead_coeff f2, ?I (mset gs2))" by auto
  thus "pl.unique_factorization_m f1 (lead_coeff f1, mset gs1)"
     "pl.unique_factorization_m f2 (lead_coeff f2, mset gs2)"
    unfolding pl.unique_factorization_m_def 
    by (auto simp: pl.Mf_def image_mset.compositionality o_def)
qed

lemma factorization_pn_to_factorization_p: assumes fact: "poly_mod.factorization_m (p^n) C (c,fs)"
  and sf: "square_free_m C" 
  and n: "n  0" 
shows "factorization_m C (c,fs)" 
proof -
  let ?q = "p^n" 
  from n m1 have q: "?q > 1" by simp
  interpret q: poly_mod_2 ?q by (standard, insert q, auto)
  from fact[unfolded q.factorization_m_def]
  have eq: "q.Mp C = q.Mp (Polynomial.smult c (prod_mset fs))" 
    and irr: " f. f ∈# fs  q.irreducibled_m f" 
    and mon: " f. f ∈# fs  monic (q.Mp f)" 
    by auto
  from arg_cong[OF eq, of Mp]
  have eq: "eq_m C (smult c (prod_mset fs))" 
    by (simp add: Mp_Mp_pow_is_Mp m1 n)
  show ?thesis unfolding factorization_m_def split
  proof (rule conjI[OF eq], intro ballI conjI)
    fix f
    assume f: "f ∈# fs" 
    from mon[OF this] have mon_qf: "monic (q.Mp f)" .
    hence lc: "lead_coeff (q.Mp f) = 1" by auto
    from mon_qf show mon_f: "monic (Mp f)" 
      by (metis Mp_Mp_pow_is_Mp m1 monic_Mp n)
    from irr[OF f] have irr: "q.irreducibled_m f" .
    hence "q.degree_m f  0" unfolding q.irreducibled_m_def by auto
    also have "q.degree_m f = degree_m f" using mon[OF f]
      by (metis Mp_Mp_pow_is_Mp m1 monic_degree_m n)
    finally have deg: "degree_m f  0" by auto
    from f obtain gs where fs: "fs = {#f#} + gs"
      by (metis mset_subset_eq_single subset_mset.add_diff_inverse)
    from eq[unfolded fs] have "Mp C = Mp (f * smult c (prod_mset gs))" by auto
    from square_free_m_factor[OF square_free_m_cong[OF sf this]]
    have sf_f: "square_free_m f" by simp
    have sf_Mf: "square_free_m (q.Mp f)"
      by (rule square_free_m_cong[OF sf_f], auto simp: Mp_Mp_pow_is_Mp n m1) 
    have "coprime (lead_coeff (q.Mp f)) p" using mon[OF f] prime by simp
    from berlekamp_hensel[OF this sf_Mf refl n, unfolded lc] obtain gs where
      qfact: "q.factorization_m (q.Mp f) (1, mset gs)"
      and " g. g  set gs  irreducible_m g" by blast
    hence fact: "q.Mp f = q.Mp (prod_list gs)" 
      and gs: " g. g set gs  irreducibled_m g  q.irreducibled_m g  monic (q.Mp g)" 
      unfolding q.factorization_m_def by auto
    from q.factorization_m_degree[OF qfact]
    have deg: "q.degree_m (q.Mp f) = sum_mset (image_mset q.degree_m (mset gs))"
      using mon_qf by fastforce
    from irr[unfolded q.irreducibled_m_def]
    have "sum_mset (image_mset q.degree_m (mset gs))  0" by (fold deg, auto)
    then obtain g gs' where gs1: "gs = g # gs'" by (cases gs, auto)
    {
      assume "gs'  []" 
      then obtain h hs where gs2: "gs' = h # hs" by (cases gs', auto)
      from deg gs[unfolded q.irreducibled_m_def] 
      have small: "q.degree_m g < q.degree_m f" 
        "q.degree_m h + sum_mset (image_mset q.degree_m (mset hs)) < q.degree_m f" 
        unfolding gs1 gs2 by auto
      have "q.eq_m f (g * (h * prod_list hs))" 
        using fact unfolding gs1 gs2 by simp
      with irr[unfolded q.irreducibled_m_def, THEN conjunct2, rule_format, of g "h * prod_list hs"]
        small(1) have "¬ q.degree_m (h * prod_list hs) < q.degree_m f" by auto
      hence "q.degree_m f  q.degree_m (h * prod_list hs)" by simp
      also have " = q.degree_m (prod_mset ({#h#} + mset hs))" by simp
      also have "  sum_mset (image_mset q.degree_m ({#h#} + mset hs))" 
        by (rule q.degree_m_prod_mset_le)
      also have " < q.degree_m f" using small(2) by simp
      finally have False by simp
    }
    hence gs1: "gs = [g]" unfolding gs1 by (cases gs', auto)
    with fact have "q.Mp f = q.Mp g" by auto
    from arg_cong[OF this, of Mp] have eq: "Mp f = Mp g" 
      by (simp add: Mp_Mp_pow_is_Mp m1 n)
    from gs[unfolded gs1] have g: "irreducibled_m g" by auto
    with eq show "irreducibled_m f" unfolding irreducibled_m_def by auto
  qed
qed

lemma unique_monic_hensel_factorization: 
  assumes ufact: "unique_factorization_m C (1,Fs)"
  and C: "monic C" "square_free_m C" 
  and n: "n  0" 
  shows " Gs. poly_mod.unique_factorization_m (p^n) C (1, Gs)"
  using ufact C
proof (induct Fs arbitrary: C rule: wf_induct[OF wf_measure[of size]])
  case (1 Fs C)
  let ?q = "p^n" 
  from n m1 have q: "?q > 1" by simp
  interpret q: poly_mod_2 ?q by (standard, insert q, auto)
  note [simp] = Mp_Mp_pow_is_Mp[OF n m1]
  note IH = 1(1)[rule_format]
  note ufact = 1(2)
  hence fact: "factorization_m C (1, Fs)" unfolding unique_factorization_m_alt_def by auto
  note monC = 1(3)
  note sf = 1(4)
  let ?n = "size Fs" 
  {
    fix d gs
    assume qfact: "q.factorization_m C (d,gs)" 
    from q.factorization_m_lead_coeff[OF this] q.monic_Mp[OF monC] 
    have d1: "q.M d = 1" by auto
    
    from factorization_pn_to_factorization_p[OF qfact sf n]
    have "factorization_m C (d,gs)" .
    with ufact d1 have "q.M d = 1" "M d = 1" "image_mset Mp gs = image_mset Mp Fs" 
      unfolding unique_factorization_m_alt_def Mf_def by auto    
  } note pre_unique = this
  show ?case
  proof (cases Fs)
    case empty
    with fact C have "Mp C = 1" unfolding factorization_m_def by auto
    hence "degree (Mp C) = 0" by simp
    with degree_m_eq_monic[OF monC m1] have "degree C = 0" by simp
    with monC have C1: "C = 1" using monic_degree_0 by blast
    with fact have fact: "q.factorization_m C (1,{#})" 
      by (auto simp: q.factorization_m_def)
    show ?thesis 
    proof (rule exI, rule q.unique_factorization_mI[OF fact])
      fix d gs
      assume fact: "q.factorization_m C (d,gs)" 
      from pre_unique[OF this, unfolded empty]
      show "q.Mf (d, gs) = q.Mf (1, {#})" by (auto simp: q.Mf_def)
    qed      
  next
    case (add D H) note FDH = this
    let ?D = "Mp D" 
    let ?H = "Mp (prod_mset H)"
    from fact have monFs: " F. F ∈# Fs  monic (Mp F)" 
      and prod: "eq_m C (prod_mset Fs)" unfolding factorization_m_def by auto
    hence monD: "monic ?D" unfolding FDH by auto
    from square_free_m_cong[OF sf, of "D * prod_mset H"] prod[unfolded FDH]
    have "square_free_m (D * prod_mset H)" by (auto simp: ac_simps)
    from square_free_m_prod_imp_coprime_m[OF this]    
    have "coprime_m D (prod_mset H)" .
    hence cop': "coprime_m ?D ?H" unfolding coprime_m_def dvdm_def Mp_Mp by simp
    from fact have eq': "eq_m (?D * ?H) C"
      unfolding FDH by (simp add: factorization_m_def ac_simps)
    note unique_hensel_binary[OF prime cop' eq' Mp_Mp Mp_Mp monD n]
    from ex1_implies_ex[OF this] this
    obtain A B where CAB: "q.eq_m (A * B) C" and monA: "monic A" and DA: "eq_m ?D A"
      and HB: "eq_m ?H B" and norm: "q.Mp A = A" "q.Mp B = B" 
      and unique: " D' H'. q.eq_m (D' * H') C 
          monic D' 
          eq_m (Mp D) D'  eq_m (Mp (prod_mset H)) H'  q.Mp D' = D'  q.Mp H' = H'
         D' = A  H' = B" by blast
    note hensel_bin_wit = CAB monA DA HB norm
    from monA have monA': "monic (q.Mp A)" by (rule q.monic_Mp)
    from q.monic_Mp[OF monC] CAB have monicP:"monic (q.Mp (A * B))" by auto
    have f4: "p. coeff (A * p) (degree (A * p)) = coeff p (degree p)"
      by (simp add: coeff_degree_mult monA)
    have f2: "p n i. coeff p n mod i = coeff (poly_mod.Mp i p) n"
        using poly_mod.M_def poly_mod.Mp_coeff by presburger
    hence "coeff B (degree B) = 0  monic B"
        using monicP f4 by (metis (no_types) norm(2) q.degree_m_eq q.m1)
    hence monB: "monic B"
        using f4 monicP by (metis norm(2) leading_coeff_0_iff)
    from monA monB have lcAB: "lead_coeff (A * B) = 1" by (rule monic_mult)
    hence copAB: "coprime (lead_coeff (A * B)) p" by auto
    from arg_cong[OF CAB, of Mp]
    have CAB': "eq_m C (A * B)" by auto
    from sf CAB' have sfAB: "square_free_m (A * B)" using square_free_m_cong by blast
    from CAB' ufact have ufact: "unique_factorization_m (A * B) (1, Fs)"
      using unique_factorization_m_cong by blast
    have "(1 :: nat)  0" "p = p ^ 1" by auto
    note u_factor = unique_factorization_factorI[OF prime ufact copAB sfAB this]
    from fact DA have "irreducibled_m D" "eq_m A D" unfolding add factorization_m_def by auto
    hence "irreducibled_m A" using Mp_irreducibled_m by fastforce
    from irreducibled_lifting[OF n _ this] have irrA: "q.irreducibled_m A" using monA
      by (simp add: m1 poly_mod.degree_m_eq_monic q.m1)
    
    from add have lenH: "(H,Fs)  measure size" by auto
    from HB fact have factB: "factorization_m B (1, H)" 
      unfolding FDH factorization_m_def by auto
    from u_factor(2)[OF factB] have ufactB: "unique_factorization_m B (1, H)" .

    from sfAB have sfB: "square_free_m B" by (rule square_free_m_factor)
    from IH[OF lenH ufactB monB sfB] obtain Bs where
      IH2: "q.unique_factorization_m B (1, Bs)" by auto
    
    from CAB have "q.Mp C = q.Mp (q.Mp A * q.Mp B)" by simp
    also have "q.Mp A * q.Mp B = q.Mp A * q.Mp (prod_mset Bs)" 
      using IH2 unfolding q.unique_factorization_m_alt_def q.factorization_m_def by auto
    also have "q.Mp  = q.Mp (A * prod_mset Bs)" by simp
    finally have factC: "q.factorization_m C (1, {# A #} + Bs)" using IH2 monA' irrA
      by (auto simp: q.unique_factorization_m_alt_def q.factorization_m_def)
    show ?thesis 
    proof (rule exI, rule q.unique_factorization_mI[OF factC])
      fix d gs
      assume dgs: "q.factorization_m C (d,gs)"
      from pre_unique[OF dgs, unfolded add] have d1: "q.M d = 1" and
        gs_fs: "image_mset Mp gs = {# Mp D #} + image_mset Mp H" by (auto simp: ac_simps)
      have "f m p ma. image_mset f m  add_mset (p::int poly) ma 
                (mb pa. m = add_mset (pa::int poly) mb  f pa = p  image_mset f mb = ma)"
          by (simp add: msed_map_invR)
      then obtain g hs where gs: "gs = {# g #} + hs" and gD: "Mp g = Mp D" 
        and hsH: "image_mset Mp hs = image_mset Mp H"
        using gs_fs by (metis add_mset_add_single union_commute)
      from dgs[unfolded q.factorization_m_def split] 
      have eq: "q.Mp C = q.Mp (smult d (prod_mset gs))" 
        and irr_mon: " g. g∈#gs  q.irreducibled_m g  monic (q.Mp g)"
        using d1 by auto
      note eq
      also have "q.Mp (smult d (prod_mset gs)) = q.Mp (smult (q.M d) (prod_mset gs))" 
        by simp
      also have " = q.Mp (prod_mset gs)" unfolding d1 by simp
      finally have eq: "q.eq_m (q.Mp g * q.Mp (prod_mset hs)) C" unfolding gs by simp
      from gD have Dg: "eq_m (Mp D) (q.Mp g)" by simp
      have "Mp (prod_mset H) = Mp (prod_mset (image_mset Mp H))" by simp
      also have " = Mp (prod_mset hs)" unfolding hsH[symmetric] by simp
      finally have Hhs: "eq_m (Mp (prod_mset H)) (q.Mp (prod_mset hs))" by simp
      from irr_mon[of g, unfolded gs] have mon_g: "monic (q.Mp g)" by auto
      from unique[OF eq mon_g Dg Hhs q.Mp_Mp q.Mp_Mp]
      have gA: "q.Mp g = A" and hsB: "q.Mp (prod_mset hs) = B" by auto
      have "q.factorization_m B (1, hs)" unfolding q.factorization_m_def split
        by (simp add: hsB norm irr_mon[unfolded gs])
      with IH2 have hsBs: "q.Mf (1,hs) = q.Mf (1,Bs)" unfolding q.unique_factorization_m_alt_def by blast
      show "q.Mf (d, gs) = q.Mf (1, {# A #} + Bs)" 
        using gA hsBs d1 unfolding gs q.Mf_def by auto
    qed
  qed
qed

theorem berlekamp_hensel_unique:
  assumes cop: "coprime (lead_coeff f) p"
  and sf: "poly_mod.square_free_m p f"
  and res: "berlekamp_hensel p n f = gs"
  and n: "n  0"
  shows "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs) ― ‹unique factorization mod p^n›"
    " g. g  set gs  poly_mod.Mp (p^n) g = g   ― ‹normalized›"
proof -
  let ?q = "p^n" 
  interpret q: poly_mod_2 ?q unfolding poly_mod_2_def using m1 n by simp
  from berlekamp_hensel[OF assms]
  have bh_fact: "q.factorization_m f (lead_coeff f, mset gs)" by auto
  from berlekamp_hensel[OF assms]
  show " g. g  set gs  poly_mod.Mp (p^n) g = g" by blast
    from prime have p1: "p > 1" by (simp add: prime_int_iff)
  let ?lc = "coeff f (degree f)" 
  define ilc where "ilc  inverse_mod ?lc (p ^ n)"
  from cop p1 n have inv: "q.M (ilc * ?lc) = 1"
    by (auto simp add: q.M_def ilc_def inverse_mod_pow)
  hence ilc0: "ilc  0" by (cases "ilc = 0", auto)
  {
    fix q
    assume "ilc * ?lc = ?q * q" 
    from arg_cong[OF this, of q.M] have "q.M (ilc * ?lc) = 0" 
      unfolding q.M_def by auto
    with inv have False by auto
  } note not_dvd = this
  let ?in = "q.Mp (smult ilc f)" 
  have mon: "monic ?in" unfolding q.Mp_coeff coeff_smult
    by (subst q.degree_m_eq[OF _ q.m1], insert not_dvd, auto simp: inv ilc0)
  have "q.Mp f = q.Mp (smult (q.M (?lc * ilc)) f)" using inv by (simp add: ac_simps)
  also have " = q.Mp (smult ?lc (smult ilc f))" by simp
  finally have f: "q.Mp f = q.Mp (smult ?lc (smult ilc f))" . 
  from arg_cong[OF f, of Mp]
  have "Mp f = Mp (smult ?lc (smult ilc f))" 
    by (simp add: Mp_Mp_pow_is_Mp n p1)
  from arg_cong[OF this, of square_free_m, unfolded Mp_square_free_m] sf
  have "square_free_m (smult (coeff f (degree f)) (smult ilc f))" by simp
  from square_free_m_smultD[OF this] have sf: "square_free_m (smult ilc f)" .
  have Mp_in: "Mp ?in = Mp (smult ilc f)" 
    by (simp add: Mp_Mp_pow_is_Mp n p1)
  from Mp_square_free_m[of ?in, unfolded Mp_in] sf have sf: "square_free_m ?in"
    unfolding Mp_square_free_m by simp
  obtain a b where "finite_field_factorization_int p ?in = (a,b)" by force
  from finite_field_factorization_int[OF sf this]
  have ufact: "unique_factorization_m ?in (a, mset b)" by auto
  from unique_factorization_m_imp_factorization[OF this]
  have fact: "factorization_m ?in (a, mset b)" .
  from factorization_m_lead_coeff[OF this] monic_Mp[OF mon] 
  have "M a = 1" by auto
  with ufact have "unique_factorization_m ?in (1, mset b)" 
    unfolding unique_factorization_m_def Mf_def by auto
  from unique_monic_hensel_factorization[OF this mon sf n]
  obtain hs where "q.unique_factorization_m ?in (1, hs)" by auto
  hence unique: "q.unique_factorization_m (smult ilc f) (1, hs)"
    unfolding unique_factorization_m_def Mf_def by auto
  from q.factorization_m_smult[OF q.unique_factorization_m_imp_factorization[OF unique], of ?lc]
  have "q.factorization_m (smult (ilc * ?lc) f) (?lc, hs)" by (simp add: ac_simps)
  moreover have "q.Mp (smult (q.M (ilc * ?lc)) f) = q.Mp f" unfolding inv by simp
  ultimately have fact: "q.factorization_m f (?lc, hs)" 
    unfolding q.factorization_m_def by auto
  have "q.unique_factorization_m f (?lc, hs)" 
  proof (rule q.unique_factorization_mI[OF fact])
    fix d us
    assume other_fact: "q.factorization_m f (d,us)" 
    from q.factorization_m_lead_coeff[OF this] have lc: "q.M d = lead_coeff (q.Mp f)" ..
    have lc: "q.M d = q.M ?lc" unfolding lc
      by (metis bh_fact q.factorization_m_lead_coeff)
    from q.factorization_m_smult[OF other_fact, of ilc] unique
    have eq: "q.Mf (d * ilc, us) = q.Mf (1, hs)" unfolding q.unique_factorization_m_def by auto
    thus "q.Mf (d, us) = q.Mf (?lc, hs)" using lc unfolding q.Mf_def by auto
  qed
  with bh_fact show "q.unique_factorization_m f (lead_coeff f, mset gs)" 
    unfolding q.unique_factorization_m_alt_def by metis
qed

lemma hensel_lifting_unique:
  assumes n: "n  0" 
  and res: "hensel_lifting p n f fs = gs"                        ― ‹result of hensel is fact. gs›
  and cop: "coprime (lead_coeff f) p" 
  and sf: "poly_mod.square_free_m p f" 
  and fact: "poly_mod.factorization_m p f (c, mset fs)"          ― ‹input is fact. fs mod p›
  and c: "c  {0..<p}" 
  and norm: "(fiset fs. set (coeffs fi)  {0..<p})" 
shows "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs)" ― ‹unique factorization mod p^n›
    "sort (map degree fs) = sort (map degree gs)"                       ― ‹degrees stay the same›
    " g. g  set gs  monic g  poly_mod.Mp (p^n) g = g     ― ‹monic and normalized›
      poly_mod.irreducible_m p g                               ― ‹irreducibility even mod p›
      poly_mod.degree_m p g = degree g   ― ‹mod p› does not change degree of g›"
proof -
  note hensel = hensel_lifting[OF assms]
  show "sort (map degree fs) = sort (map degree gs)" 
    " g. g  set gs  monic g  poly_mod.Mp (p^n) g = g  
      poly_mod.irreducible_m p g                             
      poly_mod.degree_m p g = degree g" using hensel by auto
  from berlekamp_hensel_unique[OF cop sf refl n]
  have "poly_mod.unique_factorization_m (p ^ n) f (lead_coeff f, mset (berlekamp_hensel p n f))"  by auto
  with hensel(1) show "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs)" 
    by (metis poly_mod.unique_factorization_m_alt_def)
qed

end

end

Theory Square_Free_Int_To_Square_Free_GFp

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹Reconstructing Factors of Integer Polynomials›

subsection ‹Square-Free Polynomials over Finite Fields and Integers›
theory Square_Free_Int_To_Square_Free_GFp
imports   
  Subresultants.Subresultant_Gcd 
  Polynomial_Factorization.Rational_Factorization
  Finite_Field
  Polynomial_Factorization.Square_Free_Factorization
begin

lemma square_free_int_rat: assumes sf: "square_free f"
  shows "square_free (map_poly rat_of_int f)"
proof -
  let ?r = "map_poly rat_of_int" 
  from sf[unfolded square_free_def] have f0: "f  0" " q. degree q  0  ¬ q * q dvd f" by auto
  show ?thesis
  proof (rule square_freeI)
    show "?r f  0" using f0 by auto
    fix q
    assume dq: "degree q > 0" and dvd: "q * q dvd ?r f" 
    hence q0: "q  0" by auto
    obtain q' c where norm: "rat_to_normalized_int_poly q = (c,q')" by force
    from rat_to_normalized_int_poly[OF norm] have c0: "c  0" by auto
    note q = rat_to_normalized_int_poly(1)[OF norm]
    from dvd obtain k where rf: "?r f = q * (q * k)" unfolding dvd_def by (auto simp: ac_simps)
    from rat_to_int_factor_explicit[OF this norm] obtain s where 
      f: "f = q' * smult (content f) s" by auto
    let ?s = "smult (content f) s" 
    from arg_cong[OF f, of ?r] c0 
    have "?r f = q * (smult (inverse c) (?r ?s))" 
      by (simp add: field_simps q hom_distribs)
    from arg_cong[OF this[unfolded rf], of "λ f. f div q"] q0 
    have "q * k = smult (inverse c) (?r ?s)" 
      by (metis nonzero_mult_div_cancel_left)
    from arg_cong[OF this, of "smult c"] have "?r ?s = q * smult c k" using c0
      by (auto simp: field_simps)
    from rat_to_int_factor_explicit[OF this norm] obtain t where "?s = q' * t" by blast
    from f[unfolded this] sf[unfolded square_free_def] f0 have "degree q' = 0" by auto
    with rat_to_normalized_int_poly(4)[OF norm] dq show False by auto
  qed
qed

lemma content_free_unit:
  assumes "content (p::'a::{idom,semiring_gcd} poly) = 1"
  shows "p dvd 1  degree p = 0"
  by (insert assms, auto dest!:degree0_coeffs simp: normalize_1_iff poly_dvd_1)

lemma square_free_imp_resultant_non_zero: assumes sf: "square_free (f :: int poly)"
  shows "resultant f (pderiv f)  0" 
proof (cases "degree f = 0")
  case True
  from degree0_coeffs[OF this] obtain c where f: "f = [:c:]" by auto
  with sf have c: "c  0" unfolding square_free_def by auto  
  show ?thesis unfolding f by simp
next
  case False note deg = this
  define pp where "pp = primitive_part f" 
  define c where "c = content f"
  from sf have f0: "f  0" unfolding square_free_def by auto
  hence c0: "c  0" unfolding c_def by auto
  have f: "f = smult c pp" unfolding c_def pp_def unfolding content_times_primitive_part[of f] ..
  from sf[unfolded f] c0 have sf': "square_free pp" by (metis dvd_smult smult_0_right square_free_def)  
  from deg[unfolded f] c0 have deg': " x. degree pp > 0  x" by auto
  from content_primitive_part[OF f0] have cp: "content pp = 1" unfolding pp_def .
  let ?p' = "pderiv pp" 
  {
    assume "resultant pp ?p' = 0" 
    from this[unfolded resultant_0_gcd] have "¬ coprime pp ?p'" by auto
    then obtain r where r: "r dvd pp" "r dvd ?p'" "¬ r dvd 1"
      by (blast elim: not_coprimeE) 
    from r(1) obtain k where "pp = r * k" ..
    from pos_zmult_eq_1_iff_lemma[OF arg_cong[OF this, 
      of content, unfolded content_mult cp, symmetric]] content_ge_0_int[of r]
    have cr: "content r = 1" by auto
    with r(3) content_free_unit have dr: "degree r  0" by auto
    let ?r = "map_poly rat_of_int"
    from r(1) have dvd: "?r r dvd ?r pp" unfolding dvd_def by (auto simp: hom_distribs)
    from r(2) have "?r r dvd ?r ?p'" apply (intro of_int_poly_hom.hom_dvd) by auto
    also have "?r ?p' = pderiv (?r pp)" unfolding of_int_hom.map_poly_pderiv ..
    finally have dvd': "?r r dvd pderiv (?r pp)" by auto
    from dr have dr': "degree (?r r)  0" by simp
    from square_free_imp_separable[OF square_free_int_rat[OF sf']]
    have "separable (?r pp)" .
    hence cop: "coprime (?r pp) (pderiv (?r pp))" unfolding separable_def .
    from f0 f have pp0: "pp  0" by auto
    from dvd dvd' have "?r r dvd gcd (?r pp) (pderiv (?r pp))" by auto
    from divides_degree[OF this] pp0 have "degree (?r r)  degree (gcd (?r pp) (pderiv (?r pp)))" 
      by auto
    with dr' have "degree (gcd (?r pp) (pderiv (?r pp)))  0" by auto
    hence "¬ coprime (?r pp) (pderiv (?r pp))" by auto
    with cop have False by auto
  }
  hence "resultant pp ?p'  0" by auto
  with resultant_smult_left[OF c0, of pp ?p', folded f] c0 
  have "resultant f ?p'  0" by auto
  with resultant_smult_right[OF c0, of f ?p', folded pderiv_smult f] c0
  show "resultant f (pderiv f)  0" by auto
qed

lemma large_mod_0: assumes "(n :: int) > 1" "¦k¦ < n" "k mod n = 0" shows "k = 0" 
proof -
  from k mod n = 0 have "n dvd k"
    by auto
  then obtain m where "k = n * m" ..
  with n > 1 ¦k¦ < n show ?thesis
    by (auto simp add: abs_mult)
qed

definition separable_bound :: "int poly  int" where
  "separable_bound f = max (abs (resultant f (pderiv f))) 
    (max (abs (lead_coeff f)) (abs (lead_coeff (pderiv f))))"

lemma square_free_int_imp_resultant_non_zero_mod_ring: assumes sf: "square_free f" 
  and large: "int CARD('a) > separable_bound f"
  shows "resultant (map_poly of_int f :: 'a :: prime_card mod_ring poly) (pderiv (map_poly of_int f))  0
   map_poly of_int f  (0 :: 'a mod_ring poly)" 
proof (intro conjI, rule notI)
  let ?i = "of_int :: int  'a mod_ring"
  let ?m = "of_int_poly :: _  'a mod_ring poly"
  let ?f = "?m f" 
  from sf[unfolded square_free_def] have f0: "f  0" by auto
  hence lf: "lead_coeff f  0" by auto
  {
    fix k :: int
    have C1: "int CARD('a) > 1" using prime_card[where 'a = 'a] by (auto simp: prime_nat_iff)
    assume "abs k < CARD('a)" and "?i k = 0" 
    hence "k = 0" unfolding of_int_of_int_mod_ring
        by (transfer) (rule large_mod_0[OF C1])
  } note of_int_0 = this
  from square_free_imp_resultant_non_zero[OF sf]
  have non0: "resultant f (pderiv f)  0" .
  {
    fix g :: "int poly" 
    assume abs: "abs (lead_coeff g) < CARD('a)"
    have "degree (?m g) = degree g" by (rule degree_map_poly, insert of_int_0[OF abs], auto)
  } note deg = this
  note large = large[unfolded separable_bound_def]
  from of_int_0[of "lead_coeff f"] large lf have "?i (lead_coeff f)  0" by auto
  thus f0: "?f  0" unfolding poly_eq_iff by auto  
  assume 0: "resultant ?f (pderiv ?f) = 0" 
  have "resultant ?f (pderiv ?f) = ?i (resultant f (pderiv f))"
    unfolding of_int_hom.map_poly_pderiv[symmetric]
    by (subst of_int_hom.resultant_map_poly(1)[OF deg deg], insert large, auto simp: hom_distribs)
  from of_int_0[OF _ this[symmetric, unfolded 0]] non0
  show False using large by auto
qed

lemma square_free_int_imp_separable_mod_ring: assumes sf: "square_free f" 
  and large: "int CARD('a) > separable_bound f"
  shows "separable (map_poly of_int f :: 'a :: prime_card mod_ring poly)" 
proof - 
  define g where "g = map_poly (of_int :: int  'a mod_ring) f"
  from square_free_int_imp_resultant_non_zero_mod_ring[OF sf large]
  have res: "resultant g (pderiv g)  0" and g: "g  0" unfolding g_def by auto
  from res[unfolded resultant_0_gcd] have "degree (gcd g (pderiv g)) = 0" by auto
  from degree0_coeffs[OF this]
  have "separable g" unfolding separable_def
    by (metis degree_pCons_0 g gcd_eq_0_iff is_unit_gcd is_unit_iff_degree)
  thus ?thesis unfolding g_def .
qed

lemma square_free_int_imp_square_free_mod_ring: assumes sf: "square_free f" 
  and large: "int CARD('a) > separable_bound f"
shows "square_free (map_poly of_int f :: 'a :: prime_card mod_ring poly)" 
  using separable_imp_square_free[OF square_free_int_imp_separable_mod_ring[OF assms]] .

end

Theory Suitable_Prime

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Finding a Suitable Prime›

text ‹The Berlekamp-Zassenhaus algorithm demands for an input polynomial $f$ to determine
  a prime $p$ such that $f$ is square-free mod $p$ and such that $p$ and the leading coefficient
  of $f$ are coprime. To this end, we first prove that such a prime always exists, provided that 
  $f$ is square-free over the integers. Second, we provide a generic algorithm which searches for 
  primes have a certain property $P$. Combining both results gives us the suitable prime for
  the Berlekamp-Zassenhaus algorithm.›

theory Suitable_Prime
imports 
  Poly_Mod
  Finite_Field_Record_Based
  "HOL-Types_To_Sets.Types_To_Sets"
  Poly_Mod_Finite_Field_Record_Based
  Polynomial_Record_Based
  Square_Free_Int_To_Square_Free_GFp
begin

lemma square_free_separable_GFp: fixes f :: "'a :: prime_card mod_ring poly"
  assumes card: "CARD('a) > degree f"
  and sf: "square_free f" 
  shows "separable f"
proof (rule ccontr)
  assume "¬ separable f" 
  with square_free_separable_main[OF sf]
  obtain g k where *: "f = g * k" "degree g  0" and g0: "pderiv g = 0" by auto
  from assms have f: "f  0" unfolding square_free_def by auto
  have "degree f = degree g + degree k" using f unfolding *(1)
    by (subst degree_mult_eq, auto)
  with card have card: "degree g < CARD('a)" by auto
  from *(2) obtain n where deg: "degree g = Suc n" by (cases "degree g", auto)
  from *(2) have cg: "coeff g (degree g)  0" by auto
  from g0 have "coeff (pderiv g) n = 0" by auto
  from this[unfolded coeff_pderiv, folded deg] cg
  have "of_nat (degree g) = (0 :: 'a mod_ring)" by auto
  from of_nat_0_mod_ring_dvd[OF this] have "CARD('a) dvd degree g" .
  with card show False by (simp add: deg nat_dvd_not_less)
qed
  
lemma square_free_iff_separable_GFp: assumes "degree f < CARD('a)" 
  shows "square_free (f :: 'a :: prime_card mod_ring poly) = separable f"
  using separable_imp_square_free[of f] square_free_separable_GFp[OF assms] by auto

definition separable_impl_main :: "int  'i arith_ops_record  int poly  bool" where
  "separable_impl_main p ff_ops f = separable_i ff_ops (of_int_poly_i ff_ops (poly_mod.Mp p f))" 

lemma (in prime_field_gen) separable_impl: 
  shows "separable_impl_main p ff_ops f  square_free_m f" 
  "p > degree_m f  p > separable_bound f  square_free f 
    separable_impl_main p ff_ops f" unfolding separable_impl_main_def
proof -
  define F where F: "(F :: 'a mod_ring poly) = of_int_poly (Mp f)"
  let ?f' = "of_int_poly_i ff_ops (Mp f)" 
  define f'' where "f''  of_int_poly (Mp f) :: 'a mod_ring poly"
  have rel_f[transfer_rule]: "poly_rel ?f' f''" 
    by (rule poly_rel_of_int_poly[OF refl], simp add: f''_def)
  have "separable_i ff_ops ?f'  gcd f'' (pderiv f'') = 1"
    unfolding separable_i_def by transfer_prover
  also have "  coprime f'' (pderiv f'')"
    by (auto simp add: gcd_eq_1_imp_coprime)
  finally have id: "separable_i ff_ops ?f'  separable f''" unfolding separable_def coprime_iff_coprime .
  have Mprel [transfer_rule]: "MP_Rel (Mp f) F" unfolding F MP_Rel_def
    by (simp add: Mp_f_representative)
  have "square_free f'' = square_free F" unfolding f''_def F by simp
  also have " = square_free_m (Mp f)"
    by (transfer, simp)
  also have " = square_free_m f" by simp
  finally have id2: "square_free f'' = square_free_m f" .
  from separable_imp_square_free[of f'']
  show "separable_i ff_ops ?f'  square_free_m f"
    unfolding id id2 by auto
  let ?m = "map_poly (of_int :: int  'a mod_ring)" 
  let ?f = "?m f" 
  assume "p > degree_m f" and bnd: "p > separable_bound f" and sf: "square_free f"
  with rel_funD[OF degree_MP_Rel Mprel, folded p]
  have "p > degree F" by simp
  hence "CARD('a) > degree f''" unfolding f''_def F p by simp
  from square_free_iff_separable_GFp[OF this]
  have "separable_i ff_ops ?f' = square_free f''" unfolding id id2 by simp
  also have " = square_free F" unfolding f''_def F by simp
  also have "F = ?f" unfolding F
    by (rule poly_eqI, (subst coeff_map_poly, force)+, unfold Mp_coeff, 
    auto simp: M_def, transfer, auto simp: p)
  also have "square_free ?f" using square_free_int_imp_square_free_mod_ring[where 'a = 'a, OF sf] bnd m by auto
  finally
  show "separable_i ff_ops ?f'" .
qed

context poly_mod_prime begin

lemmas separable_impl_integer = prime_field_gen.separable_impl
  [OF prime_field.prime_field_finite_field_ops_integer, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]

lemmas separable_impl_uint32 = prime_field_gen.separable_impl
  [OF prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]

lemmas separable_impl_uint64 = prime_field_gen.separable_impl
  [OF prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]

end

definition separable_impl :: "int  int poly  bool" where
  "separable_impl p = ( 
    if p  65535 
    then separable_impl_main p (finite_field_ops32 (uint32_of_int p))
    else if p  4294967295
    then separable_impl_main p (finite_field_ops64 (uint64_of_int p))
    else separable_impl_main p (finite_field_ops_integer (integer_of_int p)))" 

lemma square_free_mod_imp_square_free: assumes 
  p: "prime p" and sf: "poly_mod.square_free_m p f"
  and cop: "coprime (lead_coeff f) p" 
  shows "square_free f"
proof -
  interpret poly_mod p .
  from sf[unfolded square_free_m_def] have f0: "Mp f  0" and ndvd: " g. degree_m g > 0  ¬ (g * g) dvdm f" 
    by auto
  from f0 have ff0: "f  0" by auto
  show "square_free f" unfolding square_free_def
  proof (intro conjI[OF ff0] allI impI notI)
    fix g
    assume deg: "degree g > 0" and dvd: "g * g dvd f" 
    then obtain h where f: "f = g * g * h" unfolding dvd_def by auto
    from arg_cong[OF this, of Mp] have "(g * g) dvdm f" unfolding dvdm_def by auto
    with ndvd[of g] have deg0: "degree_m g = 0" by auto
    hence g0: "M (lead_coeff g) = 0" unfolding Mp_def using deg
      by (metis M_def deg0 p poly_mod.degree_m_eq prime_gt_1_int neq0_conv)
    from p have p0: "p  0" by auto
    from arg_cong[OF f, of lead_coeff] have "lead_coeff f = lead_coeff g * lead_coeff g * lead_coeff h" 
      by (auto simp: lead_coeff_mult)
    hence "lead_coeff g dvd lead_coeff f" by auto
    with cop have cop: "coprime (lead_coeff g) p"
      by (auto elim: coprime_imp_coprime intro: dvd_trans)
    with p0 have "coprime (lead_coeff g mod p) p" by simp
    also have "lead_coeff g mod p = 0"
      using M_def g0 by simp
    finally show False using p
      unfolding prime_int_iff
      by (simp add: prime_int_iff)
  qed
qed

lemma(in poly_mod_prime) separable_impl: 
  shows "separable_impl p f  square_free_m f"
    "nat p > degree_m f  nat p > separable_bound f  square_free f 
     separable_impl p f" 
  using
    separable_impl_integer[of f] 
    separable_impl_uint32[of f]
    separable_impl_uint64[of f]
  unfolding separable_impl_def by (auto split: if_splits)

lemma coprime_lead_coeff_large_prime: assumes prime: "prime (p :: int)" 
  and large: "p > abs (lead_coeff f)" 
  and f: "f  0" 
  shows "coprime (lead_coeff f) p"
proof -
  {
    fix lc 
    assume "0 < lc" "lc < p" 
    then have "¬ p dvd lc"
      by (simp add: zdvd_not_zless)
    with ‹prime p have "coprime p lc"
      by (auto intro: prime_imp_coprime)
    then have "coprime lc p"
      by (simp add: ac_simps)
  } note main = this
  define lc where "lc = lead_coeff f" 
  from f have lc0: "lc  0" unfolding lc_def by auto
  from large have large: "p > abs lc" unfolding lc_def by auto
  have "coprime lc p" 
  proof (cases "lc > 0")
    case True
    from large have "p > lc" by auto
    from main[OF True this] show ?thesis .
  next
    case False
    let ?mlc = "- lc" 
    from large False lc0 have "?mlc > 0" "p > ?mlc" by auto
    from main[OF this] show ?thesis by simp
  qed
  thus ?thesis unfolding lc_def by auto
qed

lemma prime_for_berlekamp_zassenhaus_exists: assumes sf: "square_free f" 
  shows " p. prime p  (coprime (lead_coeff f) p  separable_impl p f)"
proof (rule ccontr)
  from assms have f0: "f  0" unfolding square_free_def by auto
  define n where "n = max (max (abs (lead_coeff f)) (degree f)) (separable_bound f)" 
  assume contr: "¬ ?thesis"
  {
    fix p :: int
    assume prime: "prime p" and n: "p > n" 
    then interpret poly_mod_prime p by unfold_locales
    from n have large: "p > abs (lead_coeff f)" "nat p > degree f" "nat p > separable_bound f" 
      unfolding n_def by auto
    from coprime_lead_coeff_large_prime[OF prime large(1) f0]
    have cop: "coprime (lead_coeff f) p" by auto
    with prime contr have nsf: "¬ separable_impl p f" by auto
    from large(2) have "nat p > degree_m f" using degree_m_le[of f] by auto
    from separable_impl(2)[OF this large(3) sf] nsf have False by auto
  }
  hence no_large_prime: " p. prime p  p > n  False" by auto
  from bigger_prime[of "nat n"] obtain p where *: "prime p" "p > nat n" by auto
  define q where "q  int p" 
  from * have "prime q" "q > n" unfolding q_def by auto
  from no_large_prime[OF this]
  show False .
qed

definition next_primes :: "nat  nat × nat list" where
  "next_primes n = (if n = 0 then next_candidates 0 else 
    let (m,ps) = next_candidates n in (m,filter prime ps))"

partial_function (tailrec) find_prime_main :: 
  "(nat  bool)  nat  nat list  nat" where
  [code]: "find_prime_main f np ps = (case ps of []  
    let (np',ps') = next_primes np
      in find_prime_main f np' ps'
    | (p # ps)  if f p then p else find_prime_main f np ps)" 
  
definition find_prime :: "(nat  bool)  nat" where
  "find_prime f = find_prime_main f 0 []"
  

lemma next_primes: assumes res: "next_primes n = (m,ps)"
  and n: "candidate_invariant n"
  shows "candidate_invariant m" "sorted ps" "distinct ps" "n < m" 
  "set ps = {i. prime i  n  i  i < m}" 
proof -
  have "candidate_invariant m  sorted ps  distinct ps  n < m 
    set ps = {i. prime i  n  i  i < m}"
  proof (cases "n = 0")
    case True    
    with res[unfolded next_primes_def] have nc: "next_candidates 0 = (m,ps)" by auto
    from this[unfolded next_candidates_def] have ps: "ps = primes_1000" and m: "m = 1001" by auto
    have ps: "set ps = {i. prime i  n  i  i < m}" unfolding m True ps 
      by (auto simp: primes_1000)
    with next_candidates[OF nc n[unfolded True]] True
    show ?thesis by simp
  next
    case False
    with res[unfolded next_primes_def Let_def] obtain qs where nc: "next_candidates n = (m, qs)"
      and ps: "ps = filter prime qs" by (cases "next_candidates n", auto)
    have "sorted qs  sorted ps" unfolding ps using sorted_filter[of id qs prime] by auto
    with next_candidates[OF nc n] show ?thesis unfolding ps by auto
  qed
  thus "candidate_invariant m" "sorted ps" "distinct ps" "n < m" 
    "set ps = {i. prime i  n  i  i < m}" by auto
qed

lemma find_prime: assumes " n. prime n  f n"
  shows "prime (find_prime f)  f (find_prime f)" 
proof -
  from assms obtain n where fn: "prime n" "f n" by auto
  {
    fix i ps m
    assume "candidate_invariant i" 
      and "n  set ps  n  i"
      and "m = (Suc n - i, length ps)"
      and " p. p  set ps  prime p" 
    hence "prime (find_prime_main f i ps)  f (find_prime_main f i ps)"
    proof (induct m arbitrary: i ps rule: wf_induct[OF wf_measures[of "[fst, snd]"]])
      case (1 m i ps)
      note IH = 1(1)[rule_format]
      note can = 1(2)
      note n = 1(3)
      note m = 1(4)
      note ps = 1(5)
      note simps [simp] = find_prime_main.simps[of f i ps]
      show ?case 
      proof (cases ps)
        case Nil
        with n have i_n: "i  n" by auto
        obtain j qs where np: "next_primes i = (j,qs)" by force
        note j = next_primes[OF np can]
        from j(4) i_n m have meas: "((Suc n - j, length qs), m)  measures [fst, snd]" by auto 
        have n: "n  set qs  j  n" unfolding j(5) using i_n fn by auto
        show ?thesis unfolding simps using IH[OF meas j(1) n refl] j(5) by (simp add: Nil np)
      next
        case (Cons p qs)
        show ?thesis
        proof (cases "f p")
          case True
          thus ?thesis unfolding simps using ps unfolding Cons by simp
        next
          case False
          have m: "((Suc n - i, length qs), m)  measures [fst, snd]" using m unfolding Cons by simp
          have n: "n  set qs  i  n" using False n fn by (auto simp: Cons)
          from IH[OF m can n refl ps]
          show ?thesis unfolding simps using Cons False by simp
        qed
      qed
    qed
  } note main = this
  have "candidate_invariant 0" by (simp add: candidate_invariant_def)
  from main[OF this _ refl, of Nil] show ?thesis unfolding find_prime_def by auto
qed 

definition suitable_prime_bz :: "int poly  int" where
  "suitable_prime_bz f  let lc = lead_coeff f in int (find_prime (λ n. let p = int n in 
       coprime lc p  separable_impl p f))"
  
lemma suitable_prime_bz: assumes sf: "square_free f" and p: "p = suitable_prime_bz f" 
  shows "prime p" "coprime (lead_coeff f) p" "poly_mod.square_free_m p f"
proof -
  let ?lc = "lead_coeff f" 
  from prime_for_berlekamp_zassenhaus_exists[OF sf, unfolded Let_def]
  obtain P where *: "prime P  coprime ?lc P  separable_impl P f" 
    by auto
  hence "prime (nat P)" using prime_int_nat_transfer by blast
  with * have " p. prime p  coprime ?lc (int p)  separable_impl p f"
    by (intro exI [of _ "nat P"]) (auto dest: prime_gt_0_int)
  from find_prime[OF this]
  have prime: "prime p" and cop: "coprime ?lc p" and sf: "separable_impl p f" 
    unfolding p suitable_prime_bz_def Let_def by auto
  then interpret poly_mod_prime p by unfold_locales
  from prime cop separable_impl(1)[OF sf]
  show "prime p" "coprime ?lc p" "square_free_m f" by auto
qed

definition square_free_heuristic :: "int poly  int option" where
  "square_free_heuristic f = (let lc = lead_coeff f in 
    find (λ p. coprime lc p  separable_impl p f) [2, 3, 5, 7, 11, 13, 17, 19, 23])" 

lemma find_Some_D: "find f xs = Some y  y  set xs  f y" unfolding find_Some_iff by auto
  
lemma square_free_heuristic: assumes "square_free_heuristic f = Some p" 
  shows "coprime (lead_coeff f) p  separable_impl p f  prime p" 
proof -
  from find_Some_D[OF assms[unfolded square_free_heuristic_def Let_def]]
  show ?thesis by auto
qed
 
end

Theory Degree_Bound

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Maximal Degree during Reconstruction›

text ‹We define a function which computes an upper bound on the degree of
  a factor for which we have to reconstruct the integer values of the coefficients.
  This degree will determine how large the second parameter of the factor-bound will
  be.

  In essence, if the Berlekamp-factorization will produce $n$ factors with degrees
  $d_1,\ldots,d_n$, then our bound will be the sum of the $\frac{n}2$ largest degrees.
  The reason is that we will combine at most $\frac{n}2$ factors before reconstruction.

  Soundness of the bound is proven, as well as a monotonicity property.›
  
theory Degree_Bound
  imports Containers.Set_Impl (* for sort_append_Cons_swap *)
  "HOL-Library.Multiset"
  Polynomial_Interpolation.Missing_Polynomial
  "Efficient-Mergesort.Efficient_Sort"
begin

definition max_factor_degree :: "nat list  nat" where 
  "max_factor_degree degs = (let 
     ds = sort degs
     in sum_list (drop (length ds div 2) ds))"

definition degree_bound where "degree_bound vs = max_factor_degree (map degree vs)" 

lemma insort_middle: "sort (xs @ x # ys) = insort x (sort (xs @ ys))"
  by (metis append.assoc sort_append_Cons_swap sort_snoc)

lemma sum_list_insort[simp]: 
  "sum_list (insort (d :: 'a :: {comm_monoid_add,linorder}) xs) = d + sum_list xs" 
proof (induct xs)
  case (Cons x xs)
  thus ?case by (cases "d  x", auto simp: ac_simps)
qed simp

lemma half_largest_elements_mono: "sum_list (drop (length ds div 2) (sort ds))
     sum_list (drop (Suc (length ds) div 2) (insort (d :: nat) (sort ds)))"
proof -
  define n  where "n  = length ds div 2" 
  define m  where "m  = Suc (length ds) div 2"
  define xs where "xs = sort ds" 
  have xs: "sorted xs" unfolding xs_def by auto
  have nm: "m  {n, Suc n}" unfolding n_def m_def by auto
  show ?thesis unfolding n_def[symmetric] m_def[symmetric] xs_def[symmetric]
    using nm xs
  proof (induct xs arbitrary: n m d)
    case (Cons x xs n m d)
    show ?case
    proof (cases n)
      case 0
      with Cons(2) have m: "m = 0  m = 1" by auto
      show ?thesis
      proof (cases "d  x")
        case True
        hence ins: "insort d (x # xs) = d # x # xs" by auto
        show ?thesis unfolding ins 0 using True m by auto
      next
        case False
        hence ins: "insort d (x # xs) = x # insort d xs" by auto
        show ?thesis unfolding ins 0 using False m by auto
      qed
    next
      case (Suc nn)
      with Cons(2) obtain mm where m: "m = Suc mm" and mm: "mm  {nn, Suc nn}" by auto
      from Cons(3) have sort: "sorted xs" by (simp)
      note IH = Cons(1)[OF mm]
      show ?thesis
      proof (cases "d  x")
        case True
        with Cons(3) have ins: "insort d (x # xs) = d # insort x xs"
          by (cases xs, auto) 
        show ?thesis unfolding ins Suc m using IH[OF sort] by auto
      next
        case False
        hence ins: "insort d (x # xs) = x # insort d xs" by auto
        show ?thesis unfolding ins Suc m using IH[OF sort] Cons(3) by auto 
      qed
    qed
  qed auto
qed

lemma max_factor_degree_mono: 
  "max_factor_degree (map degree (fold remove1 ws vs))  max_factor_degree (map degree vs)" 
  unfolding max_factor_degree_def Let_def length_sort length_map 
proof (induct ws arbitrary: vs)
  case (Cons w ws vs)
  show ?case 
  proof (cases "w  set vs")
    case False
    hence "remove1 w vs = vs" by (rule remove1_idem)
    thus ?thesis using Cons[of vs] by auto
  next
    case True
    then obtain bef aft where vs: "vs = bef @ w # aft" and rem1: "remove1 w vs = bef @ aft"
      by (metis remove1.simps(2) remove1_append split_list_first)
    let ?exp = "λ ws vs. sum_list (drop (length (fold remove1 ws vs) div 2) 
      (sort (map degree (fold remove1 ws vs))))" 
    let ?bnd = "λ vs. sum_list (drop (length vs div 2) (sort (map degree vs)))" 
    let ?bd = "λ vs. sum_list (drop (length vs div 2) (sort vs))" 
    define ba where "ba = bef @ aft" 
    define ds where "ds = map degree ba" 
    define d  where "d  = degree w" 
    have "?exp (w # ws) vs = ?exp ws (bef @ aft)" by (auto simp: rem1)
    also have "  ?bnd ba" unfolding ba_def by (rule Cons)
    also have " = ?bd ds" unfolding ds_def by simp
    also have "  sum_list (drop (Suc (length ds) div 2) (insort d (sort ds)))" 
      by (rule half_largest_elements_mono)
    also have " = ?bnd vs" unfolding vs ds_def d_def by (simp add: ba_def insort_middle)
    finally show "?exp (w # ws) vs  ?bnd vs" by simp
  qed
qed auto

lemma mset_sub_decompose: "mset ds ⊆# mset bs + as  length ds < length bs   b1 b b2. 
   bs = b1 @ b # b2  mset ds ⊆# mset (b1 @ b2) + as"
proof (induct ds arbitrary: bs as)
  case Nil
  hence "bs = [] @ hd bs # tl bs" by auto
  thus ?case by fastforce
next
  case (Cons d ds bs as)
  have "d ∈# mset (d # ds)" by auto
  with Cons(2) have d: "d ∈# mset bs + as" by (rule mset_subset_eqD)
  hence "d  set bs  d ∈# as" by auto
  thus ?case
  proof
    assume "d  set bs" 
    from this[unfolded in_set_conv_decomp] obtain b1 b2 where bs: "bs = b1 @ d # b2" by auto
    from Cons(2) Cons(3) 
    have "mset ds ⊆# mset (b1 @ b2) + as" "length ds < length (b1 @ b2)" by (auto simp: ac_simps bs)
    from Cons(1)[OF this] obtain b1' b b2' where split: "b1 @ b2 = b1' @ b # b2'" 
      and sub: "mset ds ⊆# mset (b1' @ b2') + as" by auto
    from split[unfolded append_eq_append_conv2]
    obtain us where "b1 = b1' @ us  us @ b2 = b # b2'  b1 @ us = b1'  b2 = us @ b # b2'" ..
    thus ?thesis
    proof
      assume "b1 @ us = b1'  b2 = us @ b # b2'" 
      hence *: "b1 @ us = b1'" "b2 = us @ b # b2'" by auto
      hence bs: "bs = (b1 @ d # us) @ b # b2'" unfolding bs by auto
      show ?thesis
        by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
    next      
      assume "b1 = b1' @ us  us @ b2 = b # b2'" 
      hence *: "b1 = b1' @ us" "us @ b2 = b # b2'" by auto
      show ?thesis
      proof (cases us)
        case Nil
        with * have *: "b1 = b1'" "b2 = b # b2'" by auto
        hence bs: "bs = (b1' @ [d]) @ b # b2'" unfolding bs by simp
        show ?thesis 
          by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
      next
        case (Cons u vs)
        with * have *: "b1 = b1' @ b # vs" "vs @ b2 = b2'" by auto
        hence bs: "bs = b1' @ b # (vs @ d # b2)" unfolding bs by auto
        show ?thesis 
          by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
      qed
    qed
  next
    define as' where "as' = as - {#d#}" 
    assume "d ∈# as" 
    hence as': "as = {#d#} + as'" unfolding as'_def by auto
    from Cons(2)[unfolded as'] Cons(3) have "mset ds ⊆# mset bs + as'" "length ds < length bs" 
      by (auto simp: ac_simps)
    from Cons(1)[OF this] obtain b1 b b2 where bs: "bs = b1 @ b # b2" and 
      sub: "mset ds ⊆# mset (b1 @ b2) + as'" by auto        
    show ?thesis
      by (intro exI conjI, rule bs, insert sub, auto simp: as' ac_simps)
  qed
qed
  

lemma max_factor_degree_aux: fixes es :: "nat list" 
  assumes sub: "mset ds ⊆# mset es" 
    and len: "length ds + length ds  length es" and sort: "sorted es" 
  shows "sum_list ds  sum_list (drop (length es div 2) es)"
proof - 
  define bef where "bef = take (length es div 2) es" 
  define aft where "aft = drop (length es div 2) es" 
  have es: "es = bef @ aft" unfolding bef_def aft_def by auto
  from len have len: "length ds  length bef" "length ds  length aft" unfolding bef_def aft_def 
    by auto
  from sub have sub: "mset ds ⊆# mset bef + mset aft" unfolding es by auto
  from sort have sort: "sorted (bef @ aft)" unfolding es .
  show ?thesis unfolding aft_def[symmetric] using sub len sort
  proof (induct ds arbitrary: bef aft)
    case (Cons d ds bef aft)
    have "d ∈# mset (d # ds)" by auto
    with Cons(2) have "d ∈# mset bef + mset aft" by (rule mset_subset_eqD)
    hence "d  set bef  d  set aft" by auto
    thus ?case
    proof
      assume "d  set aft" 
      from this[unfolded in_set_conv_decomp] obtain a1 a2 where aft: "aft = a1 @ d # a2" by auto
      from Cons(4) have len_a: "length ds  length (a1 @ a2)" unfolding aft by auto
      from Cons(2)[unfolded aft] Cons(3) 
      have "mset ds ⊆# mset bef + (mset (a1 @ a2))" "length ds < length bef" by auto
      from mset_sub_decompose[OF this]
      obtain b b1 b2 
        where bef: "bef = b1 @ b # b2" and sub: "mset ds ⊆# (mset (b1 @ b2) + mset (a1 @ a2))" by auto
      from Cons(3) have len_b: "length ds  length (b1 @ b2)" unfolding bef by auto
      from Cons(5)[unfolded bef aft] have sort: "sorted ( (b1 @ b2) @ (a1 @ a2))" 
        unfolding sorted_append by auto
      note IH = Cons(1)[OF sub len_b len_a sort]
      show ?thesis using IH unfolding aft by simp
    next
      assume "d  set bef" 
      from this[unfolded in_set_conv_decomp] obtain b1 b2 where bef: "bef = b1 @ d # b2" by auto
      from Cons(3) have len_b: "length ds  length (b1 @ b2)" unfolding bef by auto
      from Cons(2)[unfolded bef] Cons(4) 
      have "mset ds ⊆# mset aft + (mset (b1 @ b2))" "length ds < length aft" by (auto simp: ac_simps)
      from mset_sub_decompose[OF this]
      obtain a a1 a2 
        where aft: "aft = a1 @ a # a2" and sub: "mset ds ⊆# (mset (b1 @ b2) + mset (a1 @ a2))" 
        by (auto simp: ac_simps)
      from Cons(4) have len_a: "length ds  length (a1 @ a2)" unfolding aft by auto
      from Cons(5)[unfolded bef aft] have sort: "sorted ( (b1 @ b2) @ (a1 @ a2))" and ad: "d  a"
        unfolding sorted_append by auto
      note IH = Cons(1)[OF sub len_b len_a sort]
      show ?thesis using IH ad unfolding aft by simp
    qed
  qed auto
qed 

lemma max_factor_degree: assumes sub: "mset ws ⊆# mset vs"
  and len: "length ws + length ws  length vs"
  shows "degree (prod_list ws)  max_factor_degree (map degree vs)"
proof -
  define ds where "ds  map degree ws"
  define es where "es  sort (map degree vs)"
  from sub len have sub: "mset ds ⊆# mset es" and len: "length ds + length ds  length es"
    and es: "sorted es"
    unfolding ds_def es_def
    by (auto simp: image_mset_subseteq_mono)
  have "degree (prod_list ws)  sum_list (map degree ws)" by (rule degree_prod_list_le)
  also have "  max_factor_degree (map degree vs)"
    unfolding max_factor_degree_def Let_def ds_def[symmetric] es_def[symmetric]
    using sub len es by (rule max_factor_degree_aux)
  finally show ?thesis .
qed

lemma degree_bound: assumes sub: "mset ws ⊆# mset vs"
  and len: "length ws + length ws  length vs"
shows "degree (prod_list ws)  degree_bound vs" 
  using max_factor_degree[OF sub len] unfolding degree_bound_def by auto

end

Theory Mahler_Measure

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Mahler Measure›

text ‹This part contains a definition of the Mahler measure, it contains Landau's inequality and
  the Graeffe-transformation. We also assemble a heuristic to approximate the Mahler's measure.›

theory Mahler_Measure
imports
  Sqrt_Babylonian.Sqrt_Babylonian
  Poly_Mod_Finite_Field_Record_Based (* stuff about polynomials *)
  Polynomial_Factorization.Fundamental_Theorem_Algebra_Factorized
  Polynomial_Factorization.Missing_Multiset
begin

context comm_monoid_list begin
  lemma induct_gen_abs:
    assumes " a r. aset lst  P (f (h a) r) (f (g a) r)"
            " x y z. P x y  P y z  P x z"
            "P (F (map g lst)) (F (map g lst))"
    shows "P (F (map h lst)) (F (map g lst)) "
  using assms proof(induct lst arbitrary:P)
    case (Cons a as P)
    have inl:"aset (a#as)" by auto
    let ?uf = "λ v w. P (f (g a) v) (f (g a) w)"
    have p_suc:"?uf (F (map g as)) (F (map g as))"
      using Cons.prems(3) by auto
    { fix r aa assume "aa  set as" hence ins:"aa  set (a#as)" by auto
      have "P (f (g a) (f (h aa) r)) (f (g a) (f (g aa) r))"
        using Cons.prems(1)[of aa "f r (g a)",OF ins]
        by (auto simp: assoc commute left_commute)
    } note h = this
    from Cons.hyps(1)[of ?uf, OF h Cons.prems(2)[simplified] p_suc]
    have e1:"P (f (g a) (F (map h as))) (f (g a) (F (map g as)))" by simp
    have e2:"P (f (h a) (F (map h as))) (f (g a) (F (map h as)))"
      using Cons.prems(1)[OF inl] by blast
    from Cons(3)[OF e2 e1] show ?case by auto next
  qed auto
end

lemma prod_induct_gen:
  assumes " a r. f (h a * r :: 'a :: {comm_monoid_mult}) = f (g a * r)"
  shows "f (vlst. h v) = f (vlst. g v)"
proof - let "?P x y" = "f x = f y"
  show ?thesis using comm_monoid_mult_class.prod_list.induct_gen_abs[of _ ?P,OF assms] by auto
qed

abbreviation complex_of_int::"int  complex" where
  "complex_of_int  of_int"

definition l2norm_list :: "int list  int" where
  "l2norm_list lst = sqrt (sum_list (map (λ a. a * a) lst))"

abbreviation l2norm :: "int poly  int" where
  "l2norm p  l2norm_list (coeffs p)"

abbreviation "norm2 p  acoeffs p. (cmod a)2" (* the square of the Euclidean/l2-norm *)

abbreviation l2norm_complex where
  "l2norm_complex p  sqrt (norm2 p)"

abbreviation height :: "int poly  int" where
  "height p  max_list (map (nat  abs) (coeffs p))"

definition complex_roots_complex where
  "complex_roots_complex (p::complex poly) = (SOME as. smult (coeff p (degree p)) (aas. [:- a, 1:]) = p  length as = degree p)"

lemma complex_roots:
  "smult (lead_coeff p) (acomplex_roots_complex p. [:- a, 1:]) = p"
  "length (complex_roots_complex p) = degree p"
  using someI_ex[OF fundamental_theorem_algebra_factorized]
  unfolding complex_roots_complex_def by simp_all

lemma complex_roots_c [simp]:
  "complex_roots_complex [:c:] = []"
  using complex_roots(2) [of "[:c:]"] by simp

declare complex_roots(2)[simp]
    
lemma complex_roots_1 [simp]:
  "complex_roots_complex 1 = []"
  using complex_roots_c [of 1] by (simp add: pCons_one)

lemma linear_term_irreducibled[simp]: "irreducibled [: a, 1:]" 
  by (rule linear_irreducibled, simp)

definition complex_roots_int where
  "complex_roots_int (p::int poly) = complex_roots_complex (map_poly of_int p)"

lemma complex_roots_int:
  "smult (lead_coeff p) (acomplex_roots_int p. [:- a, 1:]) = map_poly of_int p"
  "length (complex_roots_int p) = degree p"
proof -
  show "smult (lead_coeff p) (acomplex_roots_int p. [:- a, 1:]) = map_poly of_int p"
  "length (complex_roots_int p) = degree p"
  using complex_roots[of "map_poly of_int p"] unfolding complex_roots_int_def by auto
qed

text ‹The measure for polynomials, after K. Mahler›

definition mahler_measure_poly where
  "mahler_measure_poly p = cmod (lead_coeff p) * (acomplex_roots_complex p. (max 1 (cmod a)))"

definition mahler_measure where
  "mahler_measure p = mahler_measure_poly (map_poly complex_of_int p)"

definition mahler_measure_monic where
  "mahler_measure_monic p = (acomplex_roots_complex p. (max 1 (cmod a)))"

lemma mahler_measure_poly_via_monic :
  "mahler_measure_poly p = cmod (lead_coeff p) * mahler_measure_monic p"
  unfolding mahler_measure_poly_def mahler_measure_monic_def by simp

lemma smult_inj[simp]: assumes "(a::'a::idom)  0" shows "inj (smult a)"
proof-
  interpret map_poly_inj_zero_hom "(*) a" using assms by (unfold_locales, auto)
  show ?thesis unfolding smult_as_map_poly by (rule inj_f)
qed

definition reconstruct_poly::"'a::idom  'a list  'a poly" where
  "reconstruct_poly c roots = smult c (aroots. [:- a, 1:])"

lemma reconstruct_is_original_poly:
  "reconstruct_poly (lead_coeff p) (complex_roots_complex p) = p"
  using complex_roots(1) by (simp add: reconstruct_poly_def)

lemma reconstruct_with_type_conversion:
  "smult (lead_coeff (map_poly of_int f)) (prod_list (map (λ a. [:- a, 1:]) (complex_roots_int f)))
   = map_poly of_int f"
unfolding complex_roots_int_def complex_roots(1) by simp

lemma reconstruct_prod:
  shows "reconstruct_poly (a::complex) as * reconstruct_poly b bs
        = reconstruct_poly (a * b) (as @ bs)"
unfolding reconstruct_poly_def by auto

lemma linear_term_inj[simplified,simp]: "inj (λ a. [:- a, 1::'a::idom:])"
  unfolding inj_on_def by simp

lemma reconstruct_poly_monic_defines_mset:
  assumes "(aas. [:- a, 1:]) = (abs. [:- a, 1::'a::field:])"
  shows "mset as = mset bs"
proof -
  let ?as = "mset (map (λ a. [:- a, 1:]) as)"
  let ?bs = "mset (map (λ a. [:- a, 1:]) bs)"
  have eq_smult:"prod_mset ?as = prod_mset ?bs" using assms by (metis prod_mset_prod_list)
  have irr:" as::'a list. set_mset (mset (map (λ a. [:- a, 1:]) as))  {q. irreducible q  monic q}"
    by (auto intro!: linear_term_irreducibled[of "-_::'a", simplified])
  from monic_factorization_unique_mset[OF eq_smult irr irr]
  show ?thesis apply (subst inj_eq[OF multiset.inj_map,symmetric]) by auto
qed

lemma reconstruct_poly_defines_mset_of_argument:
  assumes "(a::'a::field)  0"
          "reconstruct_poly a as = reconstruct_poly a bs"
  shows "mset as = mset bs"
proof -
  have eq_smult:"smult a (aas. [:- a, 1:]) = smult a (abs. [:- a, 1:])"
     using assms(2) by (auto simp:reconstruct_poly_def)
  from reconstruct_poly_monic_defines_mset[OF Fun.injD[OF smult_inj[OF assms(1)] eq_smult]]
  show ?thesis by simp
qed

lemma complex_roots_complex_prod [simp]:
  assumes "f  0" "g  0"
  shows  "mset (complex_roots_complex (f * g))
        = mset (complex_roots_complex f) + mset (complex_roots_complex g)"
proof -
  let ?p = "f * g"
  let "?lc v" = "(lead_coeff (v:: complex poly))"
  have nonzero_prod:"?lc ?p  0" using assms by auto
  from reconstruct_prod[of "?lc f" "complex_roots_complex f" "?lc g" "complex_roots_complex g"]
  have "reconstruct_poly (?lc ?p) (complex_roots_complex ?p)
       = reconstruct_poly (?lc ?p) (complex_roots_complex f @ complex_roots_complex g)"
    unfolding lead_coeff_mult[symmetric] reconstruct_is_original_poly by auto
  from reconstruct_poly_defines_mset_of_argument[OF nonzero_prod this]
  show ?thesis by simp
qed

lemma mset_mult_add:
  assumes "mset (a::'a::field list) = mset b + mset c"
  shows "prod_list a = prod_list b * prod_list c"
  unfolding prod_mset_prod_list[symmetric]
  using prod_mset_Un[of "mset b" "mset c",unfolded assms[symmetric]].

lemma mset_mult_add_2:
  assumes "mset a = mset b + mset c"
  shows "prod_list (map i a::'b::field list) = prod_list (map i b) * prod_list (map i c)"
proof -
  have r:"mset (map i a) = mset (map i b) + mset (map i c) " using assms 
    by (metis map_append mset_append mset_map)
  show ?thesis using mset_mult_add[OF r] by auto
qed

lemma measure_mono_eq_prod:
  assumes "f  0" "g  0"
  shows "mahler_measure_monic (f * g) = mahler_measure_monic f * mahler_measure_monic g"
  unfolding mahler_measure_monic_def
  using mset_mult_add_2[OF complex_roots_complex_prod[OF assms],of "λ a. max 1 (cmod a)"] by simp

lemma mahler_measure_poly_0[simp]: "mahler_measure_poly 0 = 0" unfolding mahler_measure_poly_via_monic by auto

lemma measure_eq_prod: (* Remark 10.2 *)
  "mahler_measure_poly (f * g) = mahler_measure_poly f * mahler_measure_poly g"
proof -
  consider "f = 0" | "g = 0" | (both) "f  0" "g  0" by auto
  thus ?thesis proof(cases)
    case both show ?thesis unfolding mahler_measure_poly_via_monic norm_mult lead_coeff_mult
      by (auto simp: measure_mono_eq_prod[OF both])
  qed (simp_all)
qed

lemma prod_cmod[simp]:
  "cmod (alst. f a) = (alst. cmod (f a))"
  by(induct lst,auto simp:real_normed_div_algebra_class.norm_mult)

lemma lead_coeff_of_prod[simp]:
  "lead_coeff (alst. f a::'a::idom poly) = (alst. lead_coeff (f a))"
by(induct lst,auto simp:lead_coeff_mult)

lemma ineq_about_squares:assumes "x  (y::real)" shows "x  c^2 + y" using assms
  by (simp add: add.commute add_increasing2)

lemma first_coeff_le_tail:"(cmod (lead_coeff g))^2  (acoeffs g. (cmod a)^2)"
proof(induct g)
  case (pCons a p)
    thus ?case proof(cases "p = 0") case False
      show ?thesis using pCons unfolding lead_coeff_pCons(1)[OF False]
        by(cases "a = 0",simp_all add:ineq_about_squares)
    qed simp
qed simp


lemma square_prod_cmod[simp]:
  "(cmod (a * b))^2 = cmod a ^ 2 * cmod b ^ 2"
by (simp add: norm_mult power_mult_distrib)

lemma sum_coeffs_smult_cmod:
  "(acoeffs (smult v p). (cmod a)^2) = (cmod v)^2 * (acoeffs p. (cmod a)^2)" 
  (is "?l = ?r")
proof - 
  have "?l = (acoeffs p. (cmod v)^2 * (cmod a)^2)" by(cases "v=0";induct p,auto)
  thus ?thesis by (auto simp:sum_list_const_mult)
qed

abbreviation "linH a  if (cmod a > 1) then [:- 1,cnj a:] else [:- a,1:]"

lemma coeffs_cong_1[simp]: "cCons a v = cCons b v  a = b" unfolding cCons_def by auto

lemma strip_while_singleton[simp]:
  "strip_while ((=) 0) [v * a] = cCons (v * a) []" unfolding cCons_def strip_while_def by auto

lemma coeffs_times_linterm:
  shows "coeffs (pCons 0 (smult a p) + smult b p) = strip_while (HOL.eq (0::'a::{comm_ring_1}))
     (map (λ(c,d).b*d+c*a) (zip (0 # coeffs p) (coeffs p @ [0])))" proof -
{fix v
have "coeffs (smult b p + pCons (a* v) (smult a p)) = strip_while (HOL.eq 0) (map (λ(c,d).b*d+c*a) (zip ([v] @ coeffs p) (coeffs p @ [0])))"
proof(induct p arbitrary:v) case (pCons pa ps) thus ?case by auto qed auto (* just putting ;auto does not work *)
}
from this[of 0] show ?thesis by (simp add: add.commute)
qed

lemma filter_distr_rev[simp]:
  shows "filter f (rev lst) = rev (filter f lst)"
by(induct lst;auto)

lemma strip_while_filter:
  shows "filter ((≠) 0) (strip_while ((=) 0) (lst::'a::zero list)) = filter ((≠) 0) lst"
proof - {fix lst::"'a list"
  have "filter ((≠) 0) (dropWhile ((=) 0) lst) = filter ((≠) 0) lst" by (induct lst;auto)
  hence "(filter ((≠) 0) (strip_while ((=) 0) (rev lst))) = filter ((≠) 0) (rev lst)"
  unfolding strip_while_def by(simp)}
  from this[of "rev lst"] show ?thesis by simp
qed

lemma sum_stripwhile[simp]:
  assumes "f 0 = 0"
  shows "(astrip_while ((=) 0) lst. f a) = (alst. f a)"
proof -
  {fix lst
    have "(afilter ((≠) 0) lst. f a) = (alst. f a)" by(induct lst,auto simp:assms)}
  note f=this
  have "sum_list (map f (filter ((≠) 0) (strip_while ((=) 0) lst)))
       = sum_list (map f (filter ((≠) 0) lst))"
  using strip_while_filter[of lst] by(simp)
  thus ?thesis unfolding f.
qed

lemma complex_split : "Complex a b = c  (a = Re c  b = Im c)"
  using complex_surj by auto

lemma norm_times_const:"(ylst. (cmod (a * y))2) = (cmod a)2 * (ylst. (cmod y)2)"
by(induct lst,auto simp:ring_distribs)

fun bisumTail where (* Used for Landau's lemma *)
  "bisumTail f (Cons a (Cons b bs)) = f a b + bisumTail f (Cons b bs)" |
  "bisumTail f (Cons a Nil) = f a 0" |
  "bisumTail f Nil = f 1 0" (* never called, not used in proofs *)
fun bisum where
  "bisum f (Cons a as) = f 0 a + bisumTail f (Cons a as)" |
  "bisum f Nil = f 0 0"

lemma bisumTail_is_map_zip:
  "(xzip (v # l1) (l1 @ [0]). f x) = bisumTail (λx y .f (x,y))  (v#l1)"
by(induct l1 arbitrary:v,auto)
(* converting to and from bisum *)
lemma bisum_is_map_zip:
  "(xzip (0 # l1) (l1 @ [0]). f x) = bisum (λx y. f (x,y)) l1"
using bisumTail_is_map_zip[of f "hd l1" "tl l1"] by(cases l1,auto)
lemma map_zip_is_bisum:
  "bisum f l1 = ((x,y)zip (0 # l1) (l1 @ [0]). f x y)"
using bisum_is_map_zip[of "λ(x,y). f x y"] by auto

lemma bisum_outside :
  "(bisum (λ x y. f1 x - f2 x y + f3 y) lst :: 'a :: field)
  = sum_list (map f1 lst) + f1 0 - bisum f2 lst + sum_list (map f3 lst) + f3 0"
proof(cases lst)
  case (Cons a lst) show ?thesis unfolding map_zip_is_bisum Cons by(induct lst arbitrary:a,auto)
qed auto

lemma Landau_lemma:
  "(acoeffs (alst. [:- a, 1:]). (cmod a)2) = (acoeffs (alst. linH a). (cmod a)2)"
  (is "norm2 ?l = norm2 ?r")
proof -
  have a:" a. (cmod a)2 = Re (a * cnj a) " using complex_norm_square
    unfolding complex_split complex_of_real_def by simp
  have b:" x a y. (cmod (x - a * y))^2
               = (cmod x)2 - Re (a * y * cnj x + x * cnj (a * y)) + (cmod (a * y))^2"
     unfolding left_diff_distrib right_diff_distrib a complex_cnj_diff by simp
  have c:" y a x. (cmod (cnj a * x - y))2
               = (cmod (a * x))2 - Re (a * y * cnj x + x * cnj (a * y)) + (cmod y)^2"
     unfolding left_diff_distrib right_diff_distrib a complex_cnj_diff
     by (simp add: mult.assoc mult.left_commute)
  { fix f1 a
    have "norm2 ([:- a, 1 :] * f1) = bisum (λx y. cmod (x - a * y)^2) (coeffs f1)"
      by(simp add: bisum_is_map_zip[of _ "coeffs f1"] coeffs_times_linterm[of 1 _ "-a",simplified])
    also have " = norm2 f1 + cmod a^2*norm2 f1
                  - bisum (λx y. Re (a * y * cnj x + x * cnj (a * y))) (coeffs f1)"
      unfolding b bisum_outside norm_times_const by simp
    also have " = bisum (λx y. cmod (cnj a * x - y)^2) (coeffs f1)"
      unfolding c bisum_outside norm_times_const by auto
    also have " = norm2 ([:- 1, cnj a :] * f1)"
      using coeffs_times_linterm[of "cnj a" _ "-1"]
      by(simp add: bisum_is_map_zip[of _ "coeffs f1"] mult.commute)
    finally have "norm2 ([:- a, 1 :] * f1) = ".}
  hence h:" a f1. norm2 ([:- a, 1 :] * f1) = norm2 (linH a * f1)" by auto
  show ?thesis by(rule prod_induct_gen[OF h])
qed

lemma Landau_inequality:
  "mahler_measure_poly f  l2norm_complex f"
proof -
  let ?f = "reconstruct_poly (lead_coeff f) (complex_roots_complex f)"
  let ?roots = "(complex_roots_complex f)"
  let ?g = "a?roots. linH a"
  (* g is chosen such that lead_coeff_g holds, and its l2 norm is equal to f's l2 norm *)
  have max:"a. cmod (if 1 < cmod a then cnj a else 1) = max 1 (cmod a)" by(simp add:if_split,auto)
  have "a. 1 < cmod a  a  0" by auto
  hence "a. lead_coeff (linH a) = (if (cmod a > 1) then cnj a else 1)" by(auto simp:if_split)
  hence lead_coeff_g:"cmod (lead_coeff ?g) = (a?roots. max 1 (cmod a))" by(auto simp:max)
  
  have "norm2 f = (acoeffs ?f. (cmod a)^2)" unfolding reconstruct_is_original_poly..
  also have " = cmod (lead_coeff f)^2 * (acoeffs (a?roots. [:- a, 1:]). (cmod a)2)" 
    unfolding reconstruct_poly_def using sum_coeffs_smult_cmod.
  finally have fg_norm:"norm2 f = cmod (lead_coeff f)^2 * (acoeffs ?g. (cmod a)^2)"
    unfolding Landau_lemma by auto

  have "(cmod (lead_coeff ?g))^2  (acoeffs ?g. (cmod a)^2)"
    using first_coeff_le_tail by blast
  from ordered_comm_semiring_class.comm_mult_left_mono[OF this]
  have "(cmod (lead_coeff f) * cmod (lead_coeff ?g))^2  (acoeffs f. (cmod a)^2)"
    unfolding fg_norm by (simp add:power_mult_distrib)
  hence "cmod (lead_coeff f) * (a?roots. max 1 (cmod a))  sqrt (norm2 f)"
    using NthRoot.real_le_rsqrt lead_coeff_g by auto
  thus "mahler_measure_poly f  sqrt (norm2 f)"
    using reconstruct_with_type_conversion[unfolded complex_roots_int_def]
    by (simp add: mahler_measure_poly_via_monic mahler_measure_monic_def complex_roots_int_def)
qed

lemma prod_list_ge1:
  assumes "Ball (set x) (λ (a::real). a  1)"
  shows "prod_list x  1"
using assms proof(induct x)
  case (Cons a as)
    have "aset as. 1  a" "1  a" using Cons(2) by auto
    thus ?case using Cons.hyps mult_mono' by fastforce
qed auto

lemma mahler_measure_monic_ge_1: "mahler_measure_monic p  1"
  unfolding mahler_measure_monic_def by(rule prod_list_ge1,simp)

lemma mahler_measure_monic_ge_0: "mahler_measure_monic p  0"
  using mahler_measure_monic_ge_1 le_numeral_extra(1) order_trans by blast

lemma mahler_measure_ge_0: "0  mahler_measure h" unfolding mahler_measure_def mahler_measure_poly_via_monic
  by (simp add: mahler_measure_monic_ge_0)

lemma mahler_measure_constant[simp]: "mahler_measure_poly [:c:] = cmod c" 
proof -
  have main: "complex_roots_complex [:c:] = []" unfolding complex_roots_complex_def
    by (rule some_equality, auto)
  show ?thesis unfolding mahler_measure_poly_def main by auto
qed
  
lemma mahler_measure_factor[simplified,simp]: "mahler_measure_poly [:- a, 1:] = max 1 (cmod a)" 
proof -
  have main: "complex_roots_complex [:- a, 1:] = [a]" unfolding complex_roots_complex_def
  proof (rule some_equality, auto, goal_cases)
    case (1 as)
    thus ?case by (cases as, auto)
  qed
  show ?thesis unfolding mahler_measure_poly_def main by auto
qed

lemma mahler_measure_poly_explicit: "mahler_measure_poly (smult c (aas. [:- a, 1:]))
  = cmod c * (aas. (max 1 (cmod a)))" 
proof (cases "c = 0")
  case True
  thus ?thesis by auto
next
  case False note c = this
  show ?thesis
  proof (induct as)
    case (Cons a as)
    have "mahler_measure_poly (smult c (aa # as. [:- a, 1:]))
      = mahler_measure_poly (smult c (aas. [:- a, 1:]) * [: -a, 1 :])"
      by (rule arg_cong[of _ _ mahler_measure_poly], unfold list.simps prod_list.Cons mult_smult_left, simp)
    also have " = mahler_measure_poly (smult c (aas. [:- a, 1:])) * mahler_measure_poly ([:- a, 1:])" 
      (is "_ = ?l * ?r") by (rule measure_eq_prod)
    also have "?l = cmod c * (aas. max 1 (cmod a))" unfolding Cons by simp
    also have "?r = max 1 (cmod a)" by simp
    finally show ?case by simp
  next
    case Nil
    show ?case by simp
  qed
qed

lemma mahler_measure_poly_ge_1:
  assumes "h  0"
  shows "(1::real)  mahler_measure h"
proof -
  have rc: "¦real_of_int i¦ = of_int ¦i¦" for i by simp
  from assms have "cmod (lead_coeff (map_poly complex_of_int h)) > 0" by simp
  hence "cmod (lead_coeff (map_poly complex_of_int h))  1"
    by(cases "lead_coeff h = 0", auto simp del: leading_coeff_0_iff)
  from mult_mono[OF this mahler_measure_monic_ge_1 norm_ge_zero]
  show ?thesis unfolding mahler_measure_def mahler_measure_poly_via_monic
    by auto
qed

lemma mahler_measure_dvd: assumes "f  0" and "h dvd f" 
  shows "mahler_measure h  mahler_measure f" 
proof -
  from assms obtain g where f: "f = g * h" unfolding dvd_def by auto
  from f assms have g0: "g  0" by auto
  hence mg: "mahler_measure g  1" by (rule mahler_measure_poly_ge_1)
  have "1 * mahler_measure h  mahler_measure f" 
    unfolding mahler_measure_def f measure_eq_prod
      of_int_poly_hom.hom_mult unfolding mahler_measure_def[symmetric]
    by (rule mult_right_mono[OF mg mahler_measure_ge_0])    
  thus ?thesis by simp
qed


definition graeffe_poly :: "'a  'a :: comm_ring_1 list  nat  'a poly" where
  "graeffe_poly c as m = smult (c ^ (2^m)) (aas. [:- (a ^ (2^m)), 1:])" 
  

context
  fixes f :: "complex poly" and c as
  assumes f: "f = smult c (aas. [:- a, 1:])"
begin
lemma mahler_graeffe: "mahler_measure_poly (graeffe_poly c as m) = (mahler_measure_poly f)^(2^m)"
proof -
  have graeffe: "graeffe_poly c as m = smult (c ^ 2 ^ m) (a(map (λ a. a ^ 2 ^ m) as). [:- a, 1:])" 
    unfolding graeffe_poly_def
    by (rule arg_cong[of _ _ "smult (c ^ 2 ^ m)"], induct as, auto)
  {
    fix n :: nat
    assume n: "n > 0" 
    have id: "max 1 (cmod a ^ n) = max 1 (cmod a) ^ n" for a
    proof (cases "cmod a  1")
      case True 
      hence "cmod a ^ n  1" by (simp add: power_le_one)
      with True show ?thesis by (simp add: max_def)
    qed (auto simp: max_def)
    have "(xas. max 1 (cmod x ^ n)) = (aas. max 1 (cmod a)) ^ n"  
      by (induct as, auto simp: field_simps n id)
  }
  thus ?thesis unfolding f mahler_measure_poly_explicit graeffe 
    by (auto simp: o_def field_simps norm_power)
qed
end

fun drop_half :: "'a list  'a list" where
  "drop_half (x # y # ys) = x # drop_half ys" 
| "drop_half xs = xs" 

fun alternate :: "'a list  'a list × 'a list" where
  "alternate (x # y # ys) = (case alternate ys of (evn, od)  (x # evn, y # od))" 
| "alternate xs = (xs,[])" 
  
definition poly_square_subst :: "'a :: comm_ring_1 poly  'a poly" where
  "poly_square_subst f = poly_of_list (drop_half (coeffs f))" 
  
definition poly_even_odd :: "'a :: comm_ring_1 poly  'a poly × 'a poly" where
  "poly_even_odd f = (case alternate (coeffs f) of (evn,od)  (poly_of_list evn, poly_of_list od))" 

  
lemma poly_square_subst_coeff: "coeff (poly_square_subst f) i = coeff f (2 * i)" 
proof -
  have id: "coeff f (2 * i) = coeff (Poly (coeffs f)) (2 * i)" by simp
  obtain xs where xs: "coeffs f = xs" by auto
  show ?thesis unfolding poly_square_subst_def poly_of_list_def coeff_Poly_eq id xs
  proof (induct xs arbitrary: i rule: drop_half.induct)
    case (1 x y ys i) thus ?case by (cases i, auto)
  next
    case ("2_2" x i) thus ?case by (cases i, auto)
  qed auto
qed

lemma poly_even_odd_coeff: assumes "poly_even_odd f = (ev,od)"
  shows "coeff ev i = coeff f (2 * i)" "coeff od i = coeff f (2 * i + 1)" 
proof -
  have id: " i. coeff f i = coeff (Poly (coeffs f)) i" by simp
  obtain xs where xs: "coeffs f = xs" by auto
  from assms[unfolded poly_even_odd_def] 
  have ev_od: "ev = Poly (fst (alternate xs))" "od = Poly (snd (alternate xs))" 
    by (auto simp: xs split: prod.splits)
  have "coeff ev i = coeff f (2 * i)  coeff od i = coeff f (2 * i + 1)" 
    unfolding poly_of_list_def coeff_Poly_eq id xs ev_od
  proof (induct xs arbitrary: i rule: alternate.induct)
    case (1 x y ys i) thus ?case by (cases "alternate ys"; cases i, auto)
  next
    case ("2_2" x i) thus ?case by (cases i, auto)
  qed auto
  thus "coeff ev i = coeff f (2 * i)" "coeff od i = coeff f (2 * i + 1)" by auto
qed

lemma poly_square_subst: "poly_square_subst (f p (monom 1 2)) = f" 
  by (rule poly_eqI, unfold poly_square_subst_coeff, subst coeff_pcompose_x_pow_n, auto)

lemma poly_even_odd: assumes "poly_even_odd f = (g,h)" 
  shows "f = g p monom 1 2 + monom 1 1 * (h p monom 1 2)" 
proof -
  note id = poly_even_odd_coeff[OF assms]
  show ?thesis
  proof (rule poly_eqI, unfold coeff_add coeff_monom_mult)
    fix n :: nat
    obtain m i where mi: "m = n div 2" "i = n mod 2" by auto
    have nmi: "n = 2 * m + i" "i < 2" "0 < (2 :: nat)" "1 < (2 :: nat)" unfolding mi by auto
    have "(2 :: nat)  0" by auto
    show "coeff f n = coeff (g p monom 1 2) n + (if 1  n then 1 * coeff (h p monom 1 2) (n - 1) else 0)" 
    proof (cases "i = 1")
      case True
      hence id1: "2 * m + i - 1 = 2 * m + 0" by auto
      show ?thesis unfolding nmi id id1 coeff_pcompose_monom[OF nmi(2)] coeff_pcompose_monom[OF nmi(3)]
        unfolding True by auto
    next
      case False
      with nmi have i0: "i = 0" by auto
      show ?thesis 
      proof (cases m)
        case (Suc k)
        hence id1: "2 * m + i - 1 = 2 * k + 1" using i0 by auto
        show ?thesis unfolding nmi id coeff_pcompose_monom[OF nmi(2)] 
          coeff_pcompose_monom[OF nmi(4)] id1 unfolding Suc i0 by auto
      next
        case 0
        show ?thesis unfolding nmi id coeff_pcompose_monom[OF nmi(2)] unfolding i0 0 by auto
      qed
    qed
  qed
qed

context
  fixes f :: "'a :: idom poly" 
begin

lemma graeffe_0: "f = smult c (aas. [:- a, 1:])  graeffe_poly c as 0 = f" 
  unfolding graeffe_poly_def by auto

lemma graeffe_recursion: assumes "graeffe_poly c as m = f"
  shows "graeffe_poly c as (Suc m) = smult ((-1)^(degree f)) (poly_square_subst (f * f p [:0,-1:]))"  
proof -
  let ?g = "graeffe_poly c as m" 
  have "f * f p [:0,-1:] = ?g * ?g p [:0,-1:]" unfolding assms by simp
  also have "?g p [:0,-1:] = smult ((- 1) ^ length as) (smult (c ^ 2 ^ m) (aas. [:a ^ 2 ^ m, 1:]))" 
    unfolding graeffe_poly_def
  proof (induct as)
    case (Cons a as)
    have "?case = ((smult (c ^ 2 ^ m) ([:- (a ^ 2 ^ m), 1:] p [:0, - 1:] * (aas. [:- (a ^ 2 ^ m), 1:]) p [:0, - 1:]) =
     smult (-1 * (- 1) ^ length as)
      (smult (c ^ 2 ^ m) ([: a ^ 2 ^ m, 1:] * (aas. [:a ^ 2 ^ m, 1:])))))" 
      unfolding list.simps prod_list.Cons pcompose_smult pcompose_mult  by simp
    also have "smult (c ^ 2 ^ m) ([:- (a ^ 2 ^ m), 1:] p [:0, - 1:] * (aas. [:- (a ^ 2 ^ m), 1:]) p [:0, - 1:])
      = smult (c ^ 2 ^ m) ((aas. [:- (a ^ 2 ^ m), 1:]) p [:0, - 1:]) * [:- (a ^ 2 ^ m), 1:] p [:0, - 1:]" 
      unfolding mult_smult_left by simp
    also have "smult (c ^ 2 ^ m) ((aas. [:- (a ^ 2 ^ m), 1:]) p [:0, - 1:]) = 
      smult ((- 1) ^ length as) (smult (c ^ 2 ^ m) (aas. [:a ^ 2 ^ m, 1:]))"
      unfolding pcompose_smult[symmetric] Cons ..
    also have "[:- (a ^ 2 ^ m), 1:] p [:0, - 1:] = smult (-1) [: a^2^m, 1:]" by simp
    finally have id: "?case = (smult ((- 1) ^ length as) (smult (c ^ 2 ^ m) (aas. [:a ^ 2 ^ m, 1:])) * smult (- 1) [:a ^ 2 ^ m, 1:] =
      smult (- 1 * (- 1) ^ length as) (smult (c ^ 2 ^ m) ([:a ^ 2 ^ m, 1:] * (aas. [:a ^ 2 ^ m, 1:]))))" by simp
    obtain c d where id': "(aas. [:a ^ 2 ^ m, 1:]) = c" "[:a ^ 2 ^ m, 1:] = d" by auto
    show ?case unfolding id unfolding id' by (simp add: ac_simps)
  qed simp
  finally have "f * f p [:0, - 1:] =
    smult ((- 1) ^ length as * (c ^ 2 ^ m * c ^ 2 ^ m)) 
    ((aas. [:- (a ^ 2 ^ m), 1:]) * (aas. [:a ^ 2 ^ m, 1:]))" 
    unfolding graeffe_poly_def by (simp add: ac_simps)
  also have "c ^ 2 ^ m * c ^ 2 ^ m = c ^ 2 ^ (Suc m)" by (simp add: semiring_normalization_rules(36))
  also have "(aas. [:- (a ^ 2 ^ m), 1:]) * (aas. [:a ^ 2 ^ m, 1:]) = 
    (aas. [:- (a ^ 2 ^ (Suc m)), 1:]) p monom 1 2" 
  proof (induct as)
    case (Cons a as)
    have id: "(monom 1 2 :: 'a poly) = [:0,0,1:]" 
      by (metis monom_altdef pCons_0_as_mult power2_eq_square smult_1_left)
    have "(aa # as. [:- (a ^ 2 ^ m), 1:]) * (aa # as. [:a ^ 2 ^ m, 1:])
      = ([:- (a ^ 2 ^ m), 1:] * [: a ^ 2 ^ m, 1:]) * ((a as. [:- (a ^ 2 ^ m), 1:]) * (a as. [:a ^ 2 ^ m, 1:]))" 
        (is "_ = ?a * ?b")
      unfolding list.simps prod_list.Cons by (simp only: ac_simps)
    also have "?b = (aas. [:- (a ^ 2 ^ Suc m), 1:]) p monom 1 2" unfolding Cons by simp
    also have "?a = [: - (a ^ 2 ^ (Suc m)), 0 , 1:]" by (simp add: semiring_normalization_rules(36))
    also have " = [: - (a ^ 2 ^ (Suc m)), 1:] p monom 1 2" by (simp add: id)
    also have "[: - (a ^ 2 ^ (Suc m)), 1:] p monom 1 2 * (aas. [:- (a ^ 2 ^ Suc m), 1:]) p monom 1 2 =
      (aa # as. [:- (a ^ 2 ^ Suc m), 1:]) p monom 1 2" unfolding pcompose_mult[symmetric] by simp
    finally show ?case .
  qed simp
  finally have "f * f p [:0, - 1:] = (smult ((- 1) ^ length as) (graeffe_poly c as (Suc m)) p monom 1 2)" 
    unfolding graeffe_poly_def pcompose_smult by simp
  from arg_cong[OF this, of "λ f. smult ((- 1) ^ length as) (poly_square_subst f)", unfolded poly_square_subst]
  have "graeffe_poly c as (Suc m) = smult ((- 1) ^ length as) (poly_square_subst (f * f p [:0, - 1:]))" by simp
  also have " = smult ((- 1) ^ degree f) (poly_square_subst (f * f p [:0, - 1:]))" 
  proof (cases "f = 0")
    case True
    thus ?thesis by (auto simp: poly_square_subst_def)
  next
    case False
    with assms have c0: "c  0" unfolding graeffe_poly_def by auto
    from arg_cong[OF assms, of degree] 
    have "degree f = degree (smult (c ^ 2 ^ m) (aas. [:- (a ^ 2 ^ m), 1:]))" unfolding graeffe_poly_def by auto
    also have " = degree (aas. [:- (a ^ 2 ^ m), 1:])" unfolding degree_smult_eq using c0 by auto
    also have " = length as" unfolding degree_linear_factors by simp
    finally show ?thesis by simp
  qed
  finally show ?thesis .
qed
end

definition graeffe_one_step :: "'a  'a :: idom poly  'a poly" where 
  "graeffe_one_step c f = smult c (poly_square_subst (f * f p [:0,-1:]))" 
  
lemma graeffe_one_step_code[code]: fixes c :: "'a :: idom" 
  shows "graeffe_one_step c f = (case poly_even_odd f of (g,h)
   smult c (g * g - monom 1 1 * h * h))" 
proof -
  obtain g h where eo: "poly_even_odd f = (g,h)" by force
  from poly_even_odd[OF eo] have fgh: "f = g p monom 1 2 + monom 1 1 * h p monom 1 2 " by auto 
  have m2: "monom (1 :: 'a) 2 = [:0,0,1:]" "monom (1 :: 'a) 1 = [:0,1:]" 
    unfolding coeffs_eq_iff coeffs_monom
    by (auto simp add: numeral_2_eq_2)
  show ?thesis unfolding eo split graeffe_one_step_def
  proof (rule arg_cong[of _ _ "smult c"])
    let ?g = "g p monom 1 2" 
    let ?h = "h p monom 1 2" 
    let ?x = "monom (1 :: 'a) 1"
    have 2: "2 = Suc (Suc 0)" by simp
    have "f * f p [:0, - 1:] = (g p monom 1 2 + monom 1 1 * h p monom 1 2) * 
      (g p monom 1 2 + monom 1 1 * h p monom 1 2) p [:0, - 1:]" unfolding fgh by simp
    also have "(g p monom 1 2 + monom 1 1 * h p monom 1 2) p [:0, - 1:]
      = g p (monom 1 2 p [:0, - 1:]) + monom 1 1 p [:0, - 1:] * h p (monom 1 2 p [:0, - 1:])" 
      unfolding pcompose_add pcompose_mult pcompose_assoc by simp
    also have "monom (1 :: 'a) 2 p [:0, - 1:] = monom 1 2" unfolding m2 by auto
    also have "?x p [:0, - 1:] = [:0, -1:]" unfolding m2 by auto
    also have "[:0, - 1:] * h p monom 1 2 = (-?x) * ?h" unfolding m2 by simp
    also have "(?g + ?x * ?h) * (?g + (- ?x) * ?h) = (?g * ?g - (?x * ?x) * ?h * ?h)"       
      by (auto simp: field_simps)
    also have "?x * ?x = ?x p monom 1 2" unfolding mult_monom by (insert m2, simp add: 2)
    also have "(?g * ?g -  * ?h * ?h) = (g * g - ?x * h * h) p monom 1 2" 
      unfolding pcompose_diff pcompose_mult by auto
    finally have "poly_square_subst (f * f p [:0, - 1:]) 
      = poly_square_subst ((g * g - ?x * h * h) p monom 1 2)" by simp
    also have " = g * g - ?x * h * h" unfolding poly_square_subst by simp
    finally show "poly_square_subst (f * f p [:0, - 1:]) = g * g - ?x * h * h" .
  qed
qed

fun graeffe_poly_impl_main :: "'a  'a :: idom poly  nat  'a poly" where
  "graeffe_poly_impl_main c f 0 = f" 
| "graeffe_poly_impl_main c f (Suc m) = graeffe_one_step c (graeffe_poly_impl_main c f m)" 
  
lemma graeffe_poly_impl_main: assumes "f = smult c (aas. [:- a, 1:])"
  shows "graeffe_poly_impl_main ((-1)^degree f) f m = graeffe_poly c as m"
proof (induct m)
  case 0
  show ?case using graeffe_0[OF assms] by simp
next
  case (Suc m)
  have [simp]: "degree (graeffe_poly c as m) = degree f" unfolding graeffe_poly_def degree_smult_eq assms
    degree_linear_factors by auto    
  from arg_cong[OF Suc, of degree]  
  show ?case unfolding graeffe_recursion[OF Suc[symmetric]]
    by (simp add: graeffe_one_step_def)
qed

definition graeffe_poly_impl :: "'a :: idom poly  nat  'a poly" where
  "graeffe_poly_impl f = graeffe_poly_impl_main ((-1)^(degree f)) f" 

lemma graeffe_poly_impl: assumes "f = smult c (aas. [:- a, 1:])"
  shows "graeffe_poly_impl f m = graeffe_poly c as m"
  using graeffe_poly_impl_main[OF assms] unfolding graeffe_poly_impl_def .

lemma drop_half_map: "drop_half (map f xs) = map f (drop_half xs)" 
  by (induct xs rule: drop_half.induct, auto)

lemma (in inj_comm_ring_hom) map_poly_poly_square_subst: 
  "map_poly hom (poly_square_subst f) = poly_square_subst (map_poly hom f)" 
  unfolding poly_square_subst_def coeffs_map_poly_hom drop_half_map poly_of_list_def
  by (rule poly_eqI, auto simp: nth_default_map_eq)

context inj_idom_hom
begin

lemma graeffe_poly_impl_hom:
  "map_poly hom (graeffe_poly_impl f m) = graeffe_poly_impl (map_poly hom f) m"
proof -
  interpret mh: map_poly_inj_idom_hom..
  obtain c where c: "(((- 1) ^ degree f) :: 'a) = c" by auto
  have c': "(((- 1) ^ degree f) :: 'b) = hom c" unfolding c[symmetric] by (simp add:hom_distribs)
  show ?thesis unfolding graeffe_poly_impl_def degree_map_poly_hom c c'
  apply (induct m arbitrary: f; simp)
  by (unfold graeffe_one_step_def hom_distribs map_poly_poly_square_subst map_poly_pcompose,simp)
qed
end

lemma graeffe_poly_impl_mahler: "mahler_measure (graeffe_poly_impl f m) = mahler_measure f ^ 2 ^ m" 
proof -
  let ?c = "complex_of_int" 
  let ?cc = "map_poly ?c" 
  let ?f = "?cc f" 
  note eq = complex_roots(1)[of ?f]
  interpret inj_idom_hom complex_of_int by (standard, auto)
  show ?thesis  
    unfolding mahler_measure_def mahler_graeffe[OF eq[symmetric], symmetric]
     graeffe_poly_impl[OF eq[symmetric], symmetric] by (simp add: of_int_hom.graeffe_poly_impl_hom)
qed

definition mahler_landau_graeffe_approximation :: "nat  nat  int poly  int" where
  "mahler_landau_graeffe_approximation kk dd f = (let 
     no = sum_list (map (λ a. a * a) (coeffs f))
    in root_int_floor kk (dd * no))" 

lemma mahler_landau_graeffe_approximation_core: 
  assumes g: "g = graeffe_poly_impl f k" 
  shows "mahler_measure f  root (2 ^ Suc k) (real_of_int (acoeffs g. a * a))" 
proof -
  have "mahler_measure f = root (2^k) (mahler_measure f ^ (2^k))" 
    by (simp add: real_root_power_cancel mahler_measure_ge_0) 
  also have " = root (2^k) (mahler_measure g)" 
    unfolding graeffe_poly_impl_mahler g by simp
  also have " = root (2^k) (root 2 (((mahler_measure g)^2)))" 
    by (simp add: real_root_power_cancel mahler_measure_ge_0) 
  also have " = root (2^Suc k) (((mahler_measure g)^2))"
    by (metis power_Suc2 real_root_mult_exp)
  also have "  root (2 ^ Suc k) (real_of_int (acoeffs g. a * a))" 
  proof (rule real_root_le_mono, force)
    have square_mono: "0  (x :: real)  x  y  x * x  y * y" for x y
      by (simp add: mult_mono')
    obtain gs where gs: "coeffs g = gs" by auto
    have "(mahler_measure g)2  real_of_int ¦acoeffs g. a * a¦" 
      using square_mono[OF mahler_measure_ge_0 Landau_inequality[of "of_int_poly g", folded mahler_measure_def]]
      by (auto simp: power2_eq_square coeffs_map_poly o_def of_int_hom.hom_sum_list)
    also have "¦acoeffs g. a * a¦ = (acoeffs g. a * a)" unfolding gs
      by (induct gs, auto)
    finally show "(mahler_measure g)2  real_of_int (acoeffs g. a * a)" .
  qed
  finally show "mahler_measure f  root (2 ^ Suc k) (real_of_int (acoeffs g. a * a))" .
qed

lemma Landau_inequality_mahler_measure: "mahler_measure f  sqrt (real_of_int (acoeffs f. a * a))"
  by (rule order.trans[OF mahler_landau_graeffe_approximation_core[OF refl, of _ 0]],
  auto simp: graeffe_poly_impl_def sqrt_def)

lemma mahler_landau_graeffe_approximation:
  assumes g: "g = graeffe_poly_impl f k" "dd = d^(2^(Suc k))" "kk = 2^(Suc k)" 
  shows "real d * mahler_measure f  mahler_landau_graeffe_approximation kk dd g"
proof -
  have id1: "real_of_int (int (d ^ 2 ^ Suc k)) = (real d) ^ 2 ^ Suc k" by simp
  have id2: "root (2 ^ Suc k) (real d ^ 2 ^ Suc k) = real d" 
    by (simp add: real_root_power_cancel)
  show ?thesis unfolding mahler_landau_graeffe_approximation_def Let_def root_int_floor of_int_mult g(2-3)
    by (rule floor_mono, unfold real_root_mult id1 id2, rule mult_left_mono, 
    rule mahler_landau_graeffe_approximation_core[OF g(1)], auto)
qed

context 
  fixes bnd :: nat
begin
(* "dd = d^(2^(Suc k))" "kk = 2^(Suc k)" *)
function mahler_approximation_main :: "nat  int  int poly  int  nat  nat  int" where
  "mahler_approximation_main dd c g mm k kk = (let mmm = mahler_landau_graeffe_approximation kk dd g;
     new_mm = (if k = 0 then mmm else min mm mmm)
     in (if k  bnd then new_mm else 
     ― ‹abort after bnd› iterations of Graeffe transformation›
      mahler_approximation_main (dd * dd) c (graeffe_one_step c g) new_mm (Suc k) (2 * kk)))" 
  by pat_completeness auto

termination by (relation "measure (λ (dd,c,f,mm,k,kk). Suc bnd - k)", auto)
declare mahler_approximation_main.simps[simp del]

lemma mahler_approximation_main: assumes "k  0  real d * mahler_measure f  mm"
    and "c = (-1)^(degree f)" 
    and "g = graeffe_poly_impl_main c f k" "dd = d^(2^(Suc k))" "kk = 2^(Suc k)"
  shows "real d * mahler_measure f  mahler_approximation_main dd c g mm k kk" 
  using assms
proof (induct c g mm k kk rule: mahler_approximation_main.induct)
  case (1 dd c g mm k kk)
  let ?df = "real d * mahler_measure f" 
  note dd = 1(5)
  note kk = 1(6)
  note g = 1(4)
  note c = 1(3)
  note mm = 1(2)
  note IH = 1(1)  
  note mahl = mahler_approximation_main.simps[of dd c g mm k kk]
  define mmm where "mmm = mahler_landau_graeffe_approximation kk dd g" 
  define new_mm where "new_mm = (if k = 0 then mmm else min mm mmm)" 
  let ?cond = "bnd  k" 
  have id: "mahler_approximation_main dd c g mm k kk = (if ?cond then new_mm
        else mahler_approximation_main (dd * dd) c (graeffe_one_step c g) new_mm (Suc k) (2 * kk))" 
    unfolding mahl mmm_def[symmetric] Let_def new_mm_def[symmetric] by simp
  have gg: "g = (graeffe_poly_impl f k)" unfolding g graeffe_poly_impl_def c ..
  from mahler_landau_graeffe_approximation[OF gg dd kk, folded mmm_def]
  have mmm: "?df  mmm" .
  with mm have new_mm: "?df  new_mm" unfolding new_mm_def by auto
  show ?case
  proof (cases ?cond)
    case True
    show ?thesis unfolding id using True new_mm by auto
  next
    case False
    hence id: "mahler_approximation_main dd c g mm k kk = 
      mahler_approximation_main (dd * dd) c (graeffe_one_step c g) new_mm (Suc k) (2 * kk)" 
      unfolding id by auto
    have id': "graeffe_one_step c g = graeffe_poly_impl_main c f (Suc k)" 
      unfolding g by simp
    have "dd * dd = d ^ 2 ^ Suc (Suc k)" "2 * kk = 2 ^ Suc (Suc k)" unfolding dd kk
      semiring_normalization_rules(26) by auto
    from IH[OF mmm_def new_mm_def False new_mm c id' this]
    show ?thesis unfolding id .
  qed
qed 

definition mahler_approximation :: "nat  int poly  int" where
  "mahler_approximation d f = mahler_approximation_main (d * d) ((-1)^(degree f)) f (-1) 0 2" 

lemma mahler_approximation: "real d * mahler_measure f  mahler_approximation d f"
  unfolding mahler_approximation_def
  by (rule mahler_approximation_main, auto simp: semiring_normalization_rules(29)) 
end

end

Theory Factor_Bound

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹The Mignotte Bound›
theory Factor_Bound
imports 
  Mahler_Measure
  Polynomial_Factorization.Gauss_Lemma
  Subresultants.Coeff_Int 
begin

lemma binomial_mono_left: "n  N  n choose k  N choose k" 
proof (induct n arbitrary: k N)
  case (0 k N)
  thus ?case by (cases k, auto)
next
  case (Suc n k N) note IH = this
  show ?case
  proof (cases k)
    case (Suc kk)
    from IH obtain NN where N: "N = Suc NN" and le: "n  NN" by (cases N, auto)     
    show ?thesis unfolding N Suc using IH(1)[OF le] 
      by (simp add: add_le_mono)
  qed auto
qed

definition choose_int where "choose_int m n = (if n < 0 then 0 else m choose (nat n))"

lemma choose_int_suc[simp]:
  "choose_int (Suc n) i = choose_int n (i-1) + choose_int n i"
proof(cases "nat i")
  case 0 thus ?thesis by (simp add:choose_int_def) next
  case (Suc v) hence "nat (i - 1) = v" "i0" by simp_all
    thus ?thesis unfolding choose_int_def Suc by simp
qed

lemma sum_le_1_prod: assumes d: "1  d" and c: "1  c"
  shows "c + d  1 + c * (d :: real)"
proof -
  from d c have "(c - 1) * (d - 1)  0" by auto
  thus ?thesis by (auto simp: field_simps)
qed

lemma mignotte_helper_coeff_int: "cmod (coeff_int (alst. [:- a, 1:]) i)
     choose_int (length lst - 1) i * (alst. (max 1 (cmod a))) 
    + choose_int (length lst - 1) (i - 1)"
proof(induct lst arbitrary:i)
  case Nil thus ?case by (auto simp:coeff_int_def choose_int_def)
  case (Cons v xs i)
  show ?case
  proof (cases "xs = []")
    case True
    show ?thesis unfolding True
      by (cases "nat i", cases "nat (i - 1)", auto simp: coeff_int_def choose_int_def)
  next
    case False
    hence id: "length (v # xs) - 1 = Suc (length xs - 1)" by auto
    have id': "choose_int (length xs) i = choose_int (Suc (length xs - 1)) i" for i
      using False by (cases xs, auto)
    let ?r = "(axs. [:- a, 1:])"
    let ?mv = "(axs. (max 1 (cmod a)))"
    let ?c1 = "real (choose_int (length xs - 1) (i - 1 - 1))" 
    let ?c2 = "real (choose_int (length (v # xs) - 1) i - choose_int (length xs - 1) i)" 
    let "?m xs n" = "choose_int (length xs - 1) n * (axs. (max 1 (cmod a)))"
    have le1:"1  max 1 (cmod v)" by auto
    have le2:"cmod v  max 1 (cmod v)" by auto
    have mv_ge_1:"1  ?mv" by (rule prod_list_ge1, auto)
    obtain a b c d where abcd : 
      "a = real (choose_int (length xs - 1) i)" 
      "b = real (choose_int (length xs - 1) (i - 1))" 
      "c = (axs. max 1 (cmod a))" 
      "d = cmod v" by auto
    {
      have c1: "c  1" unfolding abcd by (rule mv_ge_1)
      have b: "b = 0  b  1" unfolding abcd by auto
      have a: "a = 0  a  1" unfolding abcd by auto
      hence a0: "a  0" by auto
      have acd: "a * (c * d)  a * (c * max 1 d)" using a0 c1
        by (simp add: mult_left_mono)
      from b have "b * (c + d)  b * (1  + (c * max 1 d))" 
      proof 
        assume "b  1" 
        hence "?thesis = (c + d  1 + c * max 1 d)" by simp
        also have 
        proof (cases "d  1")
          case False
          hence id: "max 1 d = 1" by simp
          show ?thesis using False unfolding id by simp
        next
          case True
          hence id: "max 1 d = d" by simp
          show ?thesis using True c1 unfolding id by (rule sum_le_1_prod)
        qed
        finally show ?thesis .
      qed auto
      with acd have "b * c + (b * d + a * (c * d))  b + (a * (c * max 1 d) + b * (c * max 1 d))" 
        by (auto simp: field_simps)
    } note abcd_main = this      
    have "cmod (coeff_int ([:- v, 1:] * ?r) i)  cmod (coeff_int ?r (i - 1)) + cmod (coeff_int (smult v ?r) i)"
      using norm_triangle_ineq4 by auto
    also have "  ?m xs (i - 1) + (choose_int (length xs - 1) (i - 1 - 1)) + cmod (coeff_int (smult v ?r) i)" 
      using Cons[of "i-1"] by auto
    also have "choose_int (length xs - 1) (i - 1) = choose_int (length (v # xs) - 1) i - choose_int (length xs - 1) i" 
      unfolding id choose_int_suc by auto
    also have "?c2 * (axs. max 1 (cmod a)) + ?c1 +
       cmod (coeff_int (smult v (axs. [:- a, 1:])) i)  
       ?c2 * (axs. max 1 (cmod a)) + ?c1 + cmod v * (
         real (choose_int (length xs - 1) i) * (axs. max 1 (cmod a)) + 
         real (choose_int (length xs - 1) (i - 1)))"
      using mult_mono'[OF order_refl Cons, of "cmod v" i, simplified] by (auto simp: norm_mult)
    also have "  ?m (v # xs) i + (choose_int (length xs) (i - 1))" using abcd_main[unfolded abcd]
      by (simp add: field_simps id')
    finally show ?thesis by simp
  qed
qed

lemma mignotte_helper_coeff_int': "cmod (coeff_int (alst. [:- a, 1:]) i)
     ((length lst - 1) choose i) * (alst. (max 1 (cmod a))) 
    + min i 1 * ((length lst - 1) choose (nat (i - 1)))"
  by (rule order.trans[OF mignotte_helper_coeff_int], auto simp: choose_int_def min_def)

lemma mignotte_helper_coeff: 
  "cmod (coeff h i)  (degree h - 1 choose i) * mahler_measure_poly h 
      + min i 1 * (degree h - 1 choose (i - 1)) * cmod (lead_coeff h)"
proof -
  let ?r = "complex_roots_complex h"
  have "cmod (coeff h i) = cmod (coeff (smult (lead_coeff h) (a?r. [:- a, 1:])) i)"
    unfolding complex_roots by auto
  also have " = cmod (lead_coeff h) * cmod (coeff (a?r. [:- a, 1:]) i)" by(simp add:norm_mult)
  also have "  cmod (lead_coeff h) * ((degree h - 1 choose i) * mahler_measure_monic h + 
    (min i 1 * ((degree h - 1) choose nat (int i - 1))))"    
    unfolding mahler_measure_monic_def
    by (rule mult_left_mono, insert mignotte_helper_coeff_int'[of ?r i], auto)
  also have " = (degree h - 1 choose i) * mahler_measure_poly h + cmod (lead_coeff h) * (
    min i 1 * ((degree h - 1) choose nat (int i - 1)))" 
    unfolding mahler_measure_poly_via_monic by (simp add: field_simps)
  also have "nat (int i - 1) = i - 1" by (cases i, auto)
  finally show ?thesis by (simp add: ac_simps split: if_splits)
qed

lemma mignotte_coeff_helper:
  "abs (coeff h i)  
   (degree h - 1 choose i) * mahler_measure h +
   (min i 1 * (degree h - 1 choose (i - 1)) * abs (lead_coeff h))"
  unfolding mahler_measure_def
  using mignotte_helper_coeff[of "of_int_poly h" i] 
  by auto

lemma cmod_through_lead_coeff[simp]:
  "cmod (lead_coeff (of_int_poly h)) = abs (lead_coeff h)"
  by simp

lemma choose_approx: "n  N  n choose k  N choose (N div 2)" 
  by (rule order.trans[OF binomial_mono_left binomial_maximum])

text ‹For Mignotte's factor bound, we currently do not support queries for individual coefficients,
  as we do not have a combined factor bound algorithm.›

definition mignotte_bound :: "int poly  nat  int" where
  "mignotte_bound f d = (let d' = d - 1; d2 = d' div 2; binom = (d' choose d2) in
     (mahler_approximation 2 binom f + binom * abs (lead_coeff f)))" 

lemma mignotte_bound_main:  
  assumes "f  0" "g dvd f" "degree g  n"
  shows "¦coeff g k¦  real (n - 1 choose k) * mahler_measure f +
       int (min k 1 * (n - 1 choose (k - 1))) * ¦lead_coeff f¦"   
proof-
  let ?bnd = 2
  let ?n = "(n - 1) choose k" 
  let ?n' = "min k 1 * ((n - 1) choose (k - 1))" 
  let ?approx = "mahler_approximation ?bnd ?n f" 
  obtain h where gh:"g * h = f" using assms by (metis dvdE)
  have nz:"g0" "h0" using gh assms(1) by auto
  have g1:"(1::real)  mahler_measure h" using mahler_measure_poly_ge_1 gh assms(1) by auto
  note g0 = mahler_measure_ge_0
  have to_n: "(degree g - 1 choose k)  real ?n"
    using binomial_mono_left[of "degree g - 1" "n - 1" k] assms(3) by auto
  have to_n': "min k 1 * (degree g - 1 choose (k - 1))  real ?n'"
    using binomial_mono_left[of "degree g - 1" "n - 1" "k - 1"] assms(3)
    by (simp add: min_def)
  have "¦coeff g k¦  (degree g - 1 choose k) * mahler_measure g
    + (real (min k 1 * (degree g - 1 choose (k - 1))) * ¦lead_coeff g¦)" 
    using mignotte_coeff_helper[of g k] by simp
  also have "  ?n * mahler_measure f + real ?n' * ¦lead_coeff f¦"
  proof (rule add_mono[OF mult_mono[OF to_n] mult_mono[OF to_n']])
    have "mahler_measure g   mahler_measure g * mahler_measure h" using g1 g0[of g]
      using mahler_measure_poly_ge_1 nz(1) by force
    thus "mahler_measure g  mahler_measure f"
      using measure_eq_prod[of "of_int_poly g" "of_int_poly h"]
      unfolding mahler_measure_def gh[symmetric] by (auto simp: hom_distribs)
    have *: "lead_coeff f = lead_coeff g * lead_coeff h" 
      unfolding arg_cong[OF gh, of lead_coeff, symmetric] by (rule lead_coeff_mult)
    have "¦lead_coeff h¦  0" using nz(2) by auto
    hence lh: "¦lead_coeff h¦  1" by linarith
    have "¦lead_coeff f¦ = ¦lead_coeff g¦ * ¦lead_coeff h¦" unfolding * by (rule abs_mult)
    also have "  ¦lead_coeff g¦ * 1" 
      by (rule mult_mono, insert lh, auto)
    finally have "¦lead_coeff g¦  ¦lead_coeff f¦" by simp
    thus "real_of_int ¦lead_coeff g¦  real_of_int ¦lead_coeff f¦" by simp
  qed (auto simp: g0)
  finally have "¦coeff g k¦  ?n * mahler_measure f + real_of_int (?n' * ¦lead_coeff f¦)" by simp
  from floor_mono[OF this, folded floor_add_int]
  have "¦coeff g k¦  floor (?n * mahler_measure f) + ?n' * ¦lead_coeff f¦" by linarith
  thus ?thesis unfolding mignotte_bound_def Let_def using mahler_approximation[of ?n f ?bnd] by auto
qed

lemma Mignotte_bound: 
  shows "of_int ¦coeff g k¦  (degree g choose k) * mahler_measure g"
proof (cases "k  degree g  g  0")
  case False
  hence "coeff g k = 0" using le_degree by (cases "g = 0", auto)
  thus ?thesis using mahler_measure_ge_0[of g] by auto
next
  case kg: True
  hence g: "g  0" "g dvd g" by auto
  from mignotte_bound_main[OF g le_refl, of k]
  have "real_of_int ¦coeff g k¦
     of_int real (degree g - 1 choose k) * mahler_measure g +
      of_int (int (min k 1 * (degree g - 1 choose (k - 1))) * ¦lead_coeff g¦)" by linarith
  also have "  real (degree g - 1 choose k) * mahler_measure g 
     + real (min k 1 * (degree g - 1 choose (k - 1))) * (of_int ¦lead_coeff g¦ * 1)"
    by (rule add_mono, force, auto)
  also have "  real (degree g - 1 choose k) * mahler_measure g 
     + real (min k 1 * (degree g - 1 choose (k - 1))) * mahler_measure g"
    by (rule add_left_mono[OF mult_left_mono], 
    unfold mahler_measure_def mahler_measure_poly_def,
    rule mult_mono, auto intro!: prod_list_ge1)  
  also have " = 
    (real ((degree g - 1 choose k) + (min k 1 * (degree g - 1 choose (k - 1))))) * mahler_measure g" 
    by (auto simp: field_simps)
  also have "(degree g - 1 choose k) + (min k 1 * (degree g - 1 choose (k - 1))) = degree g choose k"
  proof (cases "k = 0")
    case False
    then obtain kk where k: "k = Suc kk" by (cases k, auto)
    with kg obtain gg where g: "degree g = Suc gg" by (cases "degree g", auto)
    show ?thesis unfolding k g by auto
  qed auto
  finally show ?thesis .
qed

lemma mignotte_bound:  
  assumes "f  0" "g dvd f" "degree g  n"
  shows "¦coeff g k¦  mignotte_bound f n"  
proof -
  let ?bnd = 2
  let ?n = "(n - 1) choose ((n - 1) div 2)" 
  have to_n: "(n - 1 choose k)  real ?n" for k
    using choose_approx[OF le_refl] by auto
  from mignotte_bound_main[OF assms, of k]
  have "¦coeff g k¦  
    real (n - 1 choose k) * mahler_measure f + 
    int (min k 1 * (n - 1 choose (k - 1))) * ¦lead_coeff f¦" .
  also have "  real (n - 1 choose k) * mahler_measure f + 
    int ((n - 1 choose (k - 1))) * ¦lead_coeff f¦"
    by (rule add_left_mono[OF mult_right_mono], cases k, auto)
  also have "  mignotte_bound f n" 
    unfolding mignotte_bound_def Let_def
    by (rule add_mono[OF order.trans[OF floor_mono[OF mult_right_mono] 
    mahler_approximation[of ?n f ?bnd]] mult_right_mono], insert to_n mahler_measure_ge_0, auto)
  finally show ?thesis .
qed

text ‹As indicated before, at the moment the only available factor bound is Mignotte's one.
  As future work one might use a combined bound.›

definition factor_bound :: "int poly  nat  int" where
  "factor_bound = mignotte_bound"

lemma factor_bound: assumes "f  0" "g dvd f" "degree g  n"
  shows "¦coeff g k¦  factor_bound f n"
  unfolding factor_bound_def by (rule mignotte_bound[OF assms])

text ‹We further prove a result for factor bounds and scalar multiplication.›

lemma factor_bound_ge_0: "f  0  factor_bound f n  0" 
  using factor_bound[of f 1 n 0] by auto

lemma factor_bound_smult: assumes f: "f  0" and d: "d  0" 
  and dvd: "g dvd smult d f" and deg: "degree g  n" 
  shows "¦coeff g k¦  ¦d¦ * factor_bound f n" 
proof -
  let ?nf = "primitive_part f" let ?cf = "content f" 
  let ?ng = "primitive_part g" let ?cg = "content g" 
  from content_dvd_contentI[OF dvd] have "?cg dvd abs d * ?cf" 
    unfolding content_smult_int .  
  hence dvd_c: "?cg dvd d * ?cf" using d
    by (metis abs_content_int abs_mult dvd_abs_iff)
  from primitive_part_dvd_primitive_partI[OF dvd] have "?ng dvd smult (sgn d) ?nf" unfolding primitive_part_smult_int .
  hence dvd_n: "?ng dvd ?nf" using d 
    by (metis content_eq_zero_iff dvd dvd_smult_int f mult_eq_0_iff content_times_primitive_part smult_smult)
  define gc where "gc = gcd ?cf ?cg" 
  define cg where "cg = ?cg div gc"   
  from dvd d f have g: "g  0" by auto  
  from f have cf: "?cf  0" by auto
  from g have cg: "?cg  0" by auto
  hence gc: "gc  0" unfolding gc_def by auto
  have cg_dvd: "cg dvd ?cg" unfolding cg_def gc_def using g by (simp add: div_dvd_iff_mult)
  have cg_id: "?cg = cg * gc" unfolding gc_def cg_def using g cf by simp
  from dvd_smult_int[OF d dvd] have ngf: "?ng dvd f" .
  have gcf: "¦gc¦ dvd content f" unfolding gc_def by auto
  have dvd_f: "smult gc ?ng dvd f" 
  proof (rule dvd_content_dvd, 
      unfold content_smult_int content_primitive_part[OF g] 
      primitive_part_smult_int primitive_part_idemp)
    show "¦gc¦ * 1 dvd content f" using gcf by auto
    show "smult (sgn gc) (primitive_part g) dvd primitive_part f" 
      using dvd_n cf gc using zsgn_def by force
  qed    
  have "cg dvd d" using dvd_c unfolding gc_def cg_def using cf cg d
    by (simp add: div_dvd_iff_mult dvd_gcd_mult)
  then obtain h where dcg: "d = cg * h" unfolding dvd_def by auto
  with d have "h  0" by auto
  hence h1: "¦h¦  1" by simp
  have "degree (smult gc (primitive_part g)) = degree g" 
    using gc by auto
  from factor_bound[OF f dvd_f, unfolded this, OF deg, of k, unfolded coeff_smult]
  have le: "¦gc * coeff ?ng k¦  factor_bound f n" .
  note f0 = factor_bound_ge_0[OF f, of n]
  from mult_left_mono[OF le, of "abs cg"]
  have "¦cg * gc * coeff ?ng k¦  ¦cg¦ * factor_bound f n" 
    unfolding abs_mult[symmetric] by simp
  also have "cg * gc * coeff ?ng k = coeff (smult ?cg ?ng) k" unfolding cg_id by simp
  also have " = coeff g k" unfolding content_times_primitive_part by simp
  finally have "¦coeff g k¦  1 * (¦cg¦ * factor_bound f n)" by simp
  also have "  ¦h¦ * (¦cg¦ * factor_bound f n)" 
    by (rule mult_right_mono[OF h1], insert f0, auto)
  also have " = (¦cg * h¦) * factor_bound f n" by (simp add: abs_mult)
  finally show ?thesis unfolding dcg .
qed

end 

Theory Sublist_Iteration

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Iteration of Subsets of Factors›
theory Sublist_Iteration
imports 
  Polynomial_Factorization.Missing_Multiset
  Polynomial_Factorization.Missing_List
  "HOL-Library.IArray"
begin

paragraph ‹Misc lemmas›

lemma mem_snd_map: "(x. (x, y)  S)  y  snd ` S" by force

lemma filter_upt: assumes "l  m" "m < n" shows "filter ((≤) m) [l..<n] = [m..<n]"
proof(insert assms, induct n)
  case 0 then show ?case by auto
next
  case (Suc n) then show ?case by (cases "m = n", auto)
qed

lemma upt_append: "i < j  j < k  [i..<j]@[j..<k] = [i..<k]"
proof(induct k arbitrary: j)
  case 0 then show ?case by auto
next
  case (Suc k) then show ?case by (cases "j = k", auto)
qed

lemma IArray_sub[simp]: "(!!) as = (!) (IArray.list_of as)" by auto
declare IArray.sub_def[simp del]

text ‹Following lemmas in this section are for @{const subseqs}

lemma subseqs_Cons[simp]: "subseqs (x#xs) = map (Cons x) (subseqs xs) @ subseqs xs"
  by (simp add: Let_def)

declare subseqs.simps(2) [simp del]

lemma singleton_mem_set_subseqs [simp]: "[x]  set (subseqs xs)  x  set xs" by (induct xs, auto)

lemma Cons_mem_set_subseqsD: "y#ys  set (subseqs xs)  y  set xs" by (induct xs, auto)

lemma subseqs_subset: "ys  set (subseqs xs)  set ys  set xs"
  by (metis Pow_iff image_eqI subseqs_powset)

lemma Cons_mem_set_subseqs_Cons:
  "y#ys  set (subseqs (x#xs))  (y = x  ys  set (subseqs xs))  y#ys  set (subseqs xs)"
  by auto

lemma sorted_subseqs_sorted:
  "sorted xs  ys  set (subseqs xs)  sorted ys"
proof(induct xs arbitrary: ys)
  case Nil thus ?case by simp
next
  case Cons thus ?case using subseqs_subset by fastforce
qed


lemma subseqs_of_subseq: "ys  set (subseqs xs)  set (subseqs ys)  set (subseqs xs)"
proof(induct xs arbitrary: ys)
  case Nil then show ?case by auto
next
  case IHx: (Cons x xs)
  from IHx.prems show ?case
  proof(induct ys)
    case Nil then show ?case by auto
  next
    case IHy: (Cons y ys)
    from IHy.prems[unfolded subseqs_Cons]
    consider "y = x" "ys  set (subseqs xs)" | "y # ys  set (subseqs xs)" by auto
    then show ?case
    proof(cases)
      case 1 with IHx.hyps show ?thesis by auto
    next
      case 2 from IHx.hyps[OF this] show ?thesis by auto
    qed
  qed
qed

lemma mem_set_subseqs_append: "xs  set (subseqs ys)  xs  set (subseqs (zs @ ys))"
  by (induct zs, auto)

lemma Cons_mem_set_subseqs_append:
  "x  set ys  xs  set (subseqs zs)  x#xs  set (subseqs (ys@zs))"
proof(induct ys)
  case Nil then show ?case by auto
next
  case IH: (Cons y ys)
  then consider "x = y" | "x  set ys" by auto
  then show ?case
  proof(cases)
    case 1 with IH show ?thesis by (auto intro: mem_set_subseqs_append)
  next
    case 2 from IH.hyps[OF this IH.prems(2)] show ?thesis by auto
  qed
qed

lemma Cons_mem_set_subseqs_sorted:
  "sorted xs  y#ys  set (subseqs xs)  y#ys  set (subseqs (filter (λx. y  x) xs))"
by (induct xs) (auto simp: Let_def)

lemma subseqs_map[simp]: "subseqs (map f xs) = map (map f) (subseqs xs)" by (induct xs, auto)

lemma subseqs_of_indices: "map (map (nth xs)) (subseqs [0..<length xs]) = subseqs xs"
proof (induct xs)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  from this[symmetric]
  have "subseqs xs = map (map ((!) (x#xs))) (subseqs [Suc 0..<Suc (length xs)])"
    by (fold map_Suc_upt, simp)
  then show ?case by (unfold length_Cons upt_conv_Cons[OF zero_less_Suc], simp)
qed


paragraph ‹Specification›

definition "subseq_of_length n xs ys  ys  set (subseqs xs)  length ys = n"

lemma subseq_of_lengthI[intro]:
  assumes "ys  set (subseqs xs)" "length ys = n"
  shows "subseq_of_length n xs ys"
by (insert assms, unfold subseq_of_length_def, auto)

lemma subseq_of_lengthD[dest]:
  assumes "subseq_of_length n xs ys"
  shows "ys  set (subseqs xs)" "length ys = n"
  by (insert assms, unfold subseq_of_length_def, auto)

lemma subseq_of_length0[simp]: "subseq_of_length 0 xs ys  ys = []" by auto

lemma subseq_of_length_Nil[simp]: "subseq_of_length n [] ys  n = 0  ys = []"
  by (auto simp: subseq_of_length_def)

lemma subseq_of_length_Suc_upt:
  "subseq_of_length (Suc n) [0..<m] xs 
   (if n = 0 then length xs = Suc 0  hd xs < m
    else hd xs < hd (tl xs)  subseq_of_length n [0..<m] (tl xs))" (is "?l  ?r")
proof(cases "n")
  case 0
  show ?thesis
  proof(intro iffI)
    assume l: "?l"
    with 0 have 1: "length xs = Suc 0" by auto
    then have xs: "xs = [hd xs]" by (metis length_0_conv length_Suc_conv list.sel(1))
    with l have "[hd xs]  set (subseqs [0..<m])" by auto
    with 1 show "?r" by (unfold 0, auto)
  next
    assume ?r
    with 0 have 1: "length xs = Suc 0" and 2: "hd xs < m" by auto
    then have xs: "xs = [hd xs]" by (metis length_0_conv length_Suc_conv list.sel(1))
    from 2 show "?l" by (subst xs, auto simp: 0)
  qed
next
  case n: (Suc n')
  show ?thesis
  proof (intro iffI)
    assume "?l"
    with n have 1: "length xs = Suc (Suc n')" and 2: "xs  set (subseqs [0..<m])" by auto
    from 1[unfolded length_Suc_conv]
    obtain x y ys where xs: "xs = x#y#ys" and n': "length ys = n'" by auto
    have "sorted xs" by(rule sorted_subseqs_sorted[OF _ 2], auto)
    from this[unfolded xs] have "x  y" by auto
    moreover
      from 2 have "distinct xs" by (rule subseqs_distinctD, auto)
      from this[unfolded xs] have "x  y" by auto
    ultimately have "x < y" by auto
    moreover
      from 2 have "y#ys  set (subseqs [0..<m])" by (unfold xs, auto dest: Cons_in_subseqsD)
      with n n' have "subseq_of_length n [0..<m] (y#ys)" by auto
    ultimately show ?r by (auto simp: xs)
  next
    assume r: "?r"
    with n have len: "length xs = Suc (Suc n')"
     and *: "hd xs < hd (tl xs)" "tl xs  set (subseqs [0..<m])" by auto
    from len[unfolded length_Suc_conv] obtain x y ys
    where xs: "xs = x#y#ys" and n': "length ys = n'" by auto
    with * have xy: "x < y" and yys: "y#ys  set (subseqs [0..<m])" by auto
    from Cons_mem_set_subseqs_sorted[OF _ yys]
    have "y#ys  set (subseqs (filter ((≤) y) [0..<m]))" by auto
    also from Cons_mem_set_subseqsD[OF yys] have ym: "y < m" by auto
      then have "filter ((≤) y) [0..<m] = [y..<m]" by (auto intro: filter_upt)
    finally have "y#ys  set (subseqs [y..<m])" by auto
    with xy have "x#y#ys  set (subseqs (x#[y..<m]))" by auto
    also from xy have "...  set (subseqs ([0..<y] @ [y..<m]))"
      by (intro subseqs_of_subseq Cons_mem_set_subseqs_append, auto intro: subseqs_refl)
    also from xy ym have "[0..<y] @ [y..<m] = [0..<m]" by (auto intro: upt_append)
    finally have "xs  set (subseqs [0..<m])" by (unfold xs)
    with len[folded n] show ?l by auto
  qed
qed

lemma subseqs_of_length_of_indices:
  "{ ys. subseq_of_length n xs ys } = { map (nth xs) is | is. subseq_of_length n [0..<length xs] is }"
  by(unfold subseq_of_length_def, subst subseqs_of_indices[symmetric], auto)

lemma subseqs_of_length_Suc_Cons:
  "{ ys. subseq_of_length (Suc n) (x#xs) ys } =
   Cons x ` { ys. subseq_of_length n xs ys }  { ys. subseq_of_length (Suc n) xs ys }"
  by (unfold subseq_of_length_def, auto)


datatype ('a,'b,'state)subseqs_impl = Sublists_Impl
  (create_subseqs: "'b  'a list  nat  ('b × 'a list)list × 'state")
  (next_subseqs: "'state  ('b × 'a list)list × 'state")

locale subseqs_impl = 
  fixes f :: "'a  'b  'b"
  and sl_impl :: "('a,'b,'state)subseqs_impl"
begin

definition S :: "'b  'a list  nat  ('b × 'a list)set" where
  "S base elements n = { (foldr f ys base, ys) | ys. subseq_of_length n elements ys }"

end

locale correct_subseqs_impl = subseqs_impl f sl_impl
  for f :: "'a  'b  'b" 
  and sl_impl :: "('a,'b,'state)subseqs_impl" +
  fixes invariant :: "'b  'a list  nat  'state  bool" 
  assumes create_subseqs: "create_subseqs sl_impl base elements n = (out, state)  invariant base elements n state  set out = S base elements n" 
  and next_subseqs:
    "invariant base elements n state  
     next_subseqs sl_impl state = (out, state')  
     invariant base elements (Suc n) state'  set out = S base elements (Suc n)"  


(* **** old implementation *********** *)
paragraph ‹Basic Implementation›
fun subseqs_i_n_main :: "('a  'b  'b)  'b  'a list  nat  nat  ('b × 'a list) list" where
  "subseqs_i_n_main f b xs i n = (if i = 0 then [(b,[])] else if i = n then [(foldr f xs b, xs)]
    else case xs of 
      (y # ys)  map (λ (c,zs)  (c,y # zs)) (subseqs_i_n_main f (f y b) ys (i - 1) (n - 1)) 
        @ subseqs_i_n_main f b ys i (n - 1))"
declare subseqs_i_n_main.simps[simp del]

definition subseqs_length :: "('a  'b  'b)  'b  nat  'a list  ('b × 'a list) list" where
  "subseqs_length f b i xs = (
    let n = length xs in if i > n then [] else subseqs_i_n_main f b xs i n)"

lemma subseqs_length: assumes f_ac: " x y z. f x (f y z) = f y (f x z)" 
  shows "set (subseqs_length f a n xs) = 
  { (foldr f ys a, ys) | ys. ys  set (subseqs xs)  length ys = n}" 
proof -
  show ?thesis 
  proof (cases "length xs < n")
    case True
    thus ?thesis unfolding subseqs_length_def Let_def
      using length_subseqs[of xs] subseqs_length_simple_False by auto 
  next
    case False
    hence id: "(length xs < n) = False" and "n  length xs" by auto
    from this(2) show ?thesis unfolding subseqs_length_def Let_def id if_False
    proof (induct xs arbitrary: n a rule: length_induct[rule_format])
      case (1 xs n a)
      note n = 1(2)
      note IH = 1(1)
      note simp[simp] = subseqs_i_n_main.simps[of f _ xs n]
      show ?case
      proof (cases "n = 0")
        case True
        thus ?thesis unfolding simp by simp
      next
        case False note 0 = this
        show ?thesis
        proof (cases "n = length xs")
          case True
          have "?thesis = ({(foldr f xs a, xs)} = (λ ys. (foldr f ys a, ys)) ` {ys. ys  set (subseqs xs)  length ys = length xs})" 
            unfolding simp using 0 True by auto
          from this[unfolded full_list_subseqs] show ?thesis by auto
        next
          case False
          with n have n: "n < length xs" by auto
          from 0 obtain m where m: "n = Suc m" by (cases n, auto)
          from n 0 obtain y ys where xs: "xs = y # ys" by (cases xs, auto)
          from n m xs have le: "m  length ys" "n  length ys" by auto
          from xs have lt: "length ys < length xs" by auto
          have sub: "set (subseqs_i_n_main f a xs n (length xs)) = 
            (λ(c, zs). (c, y # zs)) ` set (subseqs_i_n_main f (f y a) ys m (length ys)) 
            set (subseqs_i_n_main f a ys n (length ys))" 
            unfolding simp using 0 False by (simp add: xs m)
          have fold: " ys. foldr f ys (f y a) = f y (foldr f ys a)" 
            by (induct_tac ys, auto simp: f_ac)
          show ?thesis unfolding sub IH[OF lt le(1)] IH[OF lt le(2)]
            unfolding m xs by (auto simp: Let_def fold)
        qed
      qed
    qed
  qed
qed

definition basic_subseqs_impl :: "('a  'b  'b)  ('a, 'b, 'b × 'a list × nat)subseqs_impl" where
  "basic_subseqs_impl f = Sublists_Impl 
    (λ a xs n. (subseqs_length f a n xs, (a,xs,n)))
    (λ (a,xs,n). (subseqs_length f a (Suc n) xs, (a,xs,Suc n)))"
  
lemma basic_subseqs_impl: assumes f_ac: " x y z. f x (f y z) = f y (f x z)"
  shows "correct_subseqs_impl f (basic_subseqs_impl f) 
    (λ a xs n triple. (a,xs,n) = triple)"
  by (unfold_locales; unfold subseqs_impl.S_def basic_subseqs_impl_def subseq_of_length_def,
      insert subseqs_length[of f, OF f_ac], auto)

(******** new implementation ********)
paragraph ‹Improved Implementation›

datatype ('a,'b,'state) subseqs_foldr_impl = Sublists_Foldr_Impl
  (subseqs_foldr: "'b  'a list  nat  'b list × 'state")
  (next_subseqs_foldr: "'state  'b list × 'state")

locale subseqs_foldr_impl =
  fixes f :: "'a  'b  'b"
  and impl :: "('a,'b,'state) subseqs_foldr_impl"
begin
definition S where "S base elements n  { foldr f ys base | ys. subseq_of_length n elements ys }"
end

locale correct_subseqs_foldr_impl = subseqs_foldr_impl f impl
  for f and impl :: "('a,'b,'state) subseqs_foldr_impl" +
  fixes invariant :: "'b  'a list  nat  'state  bool"
  assumes subseqs_foldr:
    "subseqs_foldr impl base elements n = (out, state) 
     invariant base elements n state  set out = S base elements n" 
  and next_subseqs_foldr:
    "next_subseqs_foldr impl state = (out, state')  invariant base elements n state 
     invariant base elements (Suc n) state'  set out = S base elements (Suc n)"

locale my_subseqs =
  fixes f :: "'a  'b  'b"
begin

context fixes head :: "'a" and tail :: "'a iarray"
begin

fun next_subseqs1 and next_subseqs2
where "next_subseqs1 ret0 ret1 [] = (ret0, (head, tail, ret1))"
  |   "next_subseqs1 ret0 ret1 ((i,v)#prevs) = next_subseqs2 (f head v # ret0) ret1 prevs v [0..<i]"
  |   "next_subseqs2 ret0 ret1 prevs v [] = next_subseqs1 ret0 ret1 prevs"
  |   "next_subseqs2 ret0 ret1 prevs v (j#js) =
       (let v' = f (tail !! j) v in next_subseqs2 (v' # ret0) ((j,v') # ret1) prevs v js)"

definition "next_subseqs2_set v js  { (j, f (tail !! j) v) | j. j  set js }"

definition "out_subseqs2_set v js  { f (tail !! j) v | j. j  set js }"

definition "next_subseqs1_set prevs   { next_subseqs2_set v [0..<i] | v i. (i,v)  set prevs }"

definition "out_subseqs1_set prevs 
  (f head  snd) ` set prevs  ( { out_subseqs2_set v [0..<i] | v i. (i,v)  set prevs })"

fun next_subseqs1_spec where
  "next_subseqs1_spec out nexts prevs (out', (head',tail',nexts')) 
   set nexts' = set nexts  next_subseqs1_set prevs 
   set out' = set out  out_subseqs1_set prevs"

fun next_subseqs2_spec where
  "next_subseqs2_spec out nexts prevs v js (out', (head',tail',nexts')) 
   set nexts' = set nexts  next_subseqs1_set prevs  next_subseqs2_set v js 
   set out' = set out  out_subseqs1_set prevs  out_subseqs2_set v js"

lemma next_subseqs2_Cons:
  "next_subseqs2_set v (j#js) = insert (j, f (tail!!j) v) (next_subseqs2_set v js)"
  by (auto simp: next_subseqs2_set_def)

lemma out_subseqs2_Cons:
  "out_subseqs2_set v (j#js) = insert (f (tail!!j) v) (out_subseqs2_set v js)"
  by (auto simp: out_subseqs2_set_def)

lemma next_subseqs1_set_as_next_subseqs2_set:
  "next_subseqs1_set ((i,v) # prevs) = next_subseqs1_set prevs  next_subseqs2_set v [0..<i]"
  by (auto simp: next_subseqs1_set_def)

lemma out_subseqs1_set_as_out_subseqs2_set:
  "out_subseqs1_set ((i,v) # prevs) =
   { f head v }  out_subseqs1_set prevs  out_subseqs2_set v [0..<i]"
  by (auto simp: out_subseqs1_set_def)

lemma next_subseqs1_spec:
  shows "out nexts. next_subseqs1_spec out nexts prevs (next_subseqs1 out nexts prevs)"
    and "out nexts. next_subseqs2_spec out nexts prevs v js (next_subseqs2 out nexts prevs v js)"
proof(induct rule: next_subseqs1_next_subseqs2.induct)
  case (1 ret0 ret1)
  then show ?case by (simp add: next_subseqs1_set_def out_subseqs1_set_def)
next
  case (2 ret0 ret1 i v prevs)
  show ?case
  proof(cases "next_subseqs1 out nexts ((i, v) # prevs)")
    case split: (fields out' head' tail' nexts')
    have "next_subseqs2_spec (f head v # out) nexts prevs v [0..<i] (out', (head',tail',nexts'))"
      by (fold split, unfold next_subseqs1.simps, rule 2)
    then show ?thesis
      apply (unfold next_subseqs2_spec.simps split)
      by (auto simp: next_subseqs1_set_as_next_subseqs2_set out_subseqs1_set_as_out_subseqs2_set)
  qed
next
  case (3 ret0 ret1 prevs v)
  show ?case
  proof (cases "next_subseqs1 out nexts prevs")
    case split: (fields out' head' tail' nexts')
    from 3[of out nexts] show ?thesis by(simp add: split next_subseqs2_set_def out_subseqs2_set_def)
  qed
next
  case (4 ret0 ret1 prevs v j js)
  define tj where "tj = tail !! j"
  define nexts'' where "nexts'' = (j, f tj v) # nexts"
  define out'' where "out'' = (f tj v) # out"
  let ?n = "next_subseqs2 out'' nexts'' prevs v js"
  show ?case
  proof (cases ?n)
    case split: (fields out' head' tail' nexts')
    show ?thesis
      apply (unfold next_subseqs2.simps Let_def)
      apply (fold tj_def)
      apply (fold out''_def nexts''_def)
      apply (unfold split next_subseqs2_spec.simps next_subseqs2_Cons out_subseqs2_Cons)
      using 4[OF refl, of out'' nexts'', unfolded split]
      apply (auto simp: tj_def nexts''_def out''_def)
      done
  qed
qed

end

fun next_subseqs where "next_subseqs (head,tail,prevs) = next_subseqs1 head tail [] [] prevs"

fun create_subseqs
where "create_subseqs base elements 0 = (
       if elements = [] then ([base],(undefined, IArray [], []))
       else let head = hd elements; tail = IArray (tl elements) in
         ([base], (head, tail, [(IArray.length tail, base)])))"
  |   "create_subseqs base elements (Suc n) =
       next_subseqs (snd (create_subseqs base elements n))"

definition impl where "impl = Sublists_Foldr_Impl create_subseqs next_subseqs"

sublocale subseqs_foldr_impl f impl .

definition set_prevs where "set_prevs base tail n 
  { (i, foldr f (map ((!) tail) is) base) | i is.
   subseq_of_length n [0..<length tail] is  i = (if n = 0 then length tail else hd is) }"

lemma snd_set_prevs:
  "snd ` (set_prevs base tail n) = (λas. foldr f as base) ` { as. subseq_of_length n tail as }"
  by (subst subseqs_of_length_of_indices, auto simp: set_prevs_def image_Collect)


fun invariant where "invariant base elements n (head,tail,prevs) =
  (if elements = [] then prevs = []
   else head = hd elements  tail = IArray (tl elements)  set prevs = set_prevs base (tl elements) n)"


lemma next_subseq_preserve:
  assumes "next_subseqs (head,tail,prevs) = (out, (head',tail',prevs'))"
  shows "head' = head" "tail' = tail"
proof-
  define P :: "'b list × _ × _ × (nat × 'b) list  bool"
  where "P  λ (out, (head',tail',prevs')). head' = head  tail' = tail"
  { fix ret0 ret1 v js
    have *: "P (next_subseqs1 head tail ret0 ret1 prevs)"
     and  "P (next_subseqs2 head tail ret0 ret1 prevs v js)"
    by(induct rule: next_subseqs1_next_subseqs2.induct, simp add: P_def, auto simp: Let_def)
  }
  from this(1)[unfolded P_def, of "[]" "[]", folded next_subseqs.simps] assms
  show "head' = head" "tail' = tail" by auto
qed

lemma next_subseqs_spec:
  assumes nxt: "next_subseqs (head,tail,prevs) = (out, (head',tail',prevs'))"
  shows "set prevs' = { (j, f (tail !! j) v) | v i j. (i,v)  set prevs  j < i }" (is "?g1")
    and "set out = (f head  snd) ` set prevs  snd ` set prevs'" (is "?g2")
proof-
  note next_subseqs1_spec(1)[of head tail Nil Nil prevs]
  note this[unfolded nxt[simplified]]
  note this[unfolded next_subseqs1_spec.simps]
  note this[unfolded next_subseqs1_set_def out_subseqs1_set_def]
  note * = this[unfolded next_subseqs2_set_def out_subseqs2_set_def]
  then show g1: ?g1 by auto
  also have "snd ` ... =  ( {{(f (tail !! j) v) | j. j < i} | v i. (i, v)  set prevs})"
     by (unfold image_Collect, auto)
  finally have **: "snd ` set prevs' = ...".
  with conjunct2[OF *] show ?g2 by simp
qed

lemma next_subseq_prevs:
  assumes nxt: "next_subseqs (head,tail,prevs) = (out, (head',tail',prevs'))"
      and inv_prevs: "set prevs = set_prevs base (IArray.list_of tail) n"
  shows "set prevs' = set_prevs base (IArray.list_of tail) (Suc n)" (is "?l = ?r")
proof(intro equalityI subsetI)
  fix t
  assume r: "t  ?r"
  from this[unfolded set_prevs_def] obtain iis
  where t: "t = (hd iis, foldr f (map ((!!) tail) iis) base)"
    and sl: "subseq_of_length (Suc n) [0..<IArray.length tail] iis" by auto
  from sl have "length iis > 0" by auto
  then obtain i "is" where iis: "iis = i#is" by (meson list.set_cases nth_mem)
  define v where "v = foldr f (map ((!!) tail) is) base"
  note sl[unfolded subseq_of_length_Suc_upt]
  note nxt = next_subseqs_spec[OF nxt]
  show "t  ?l"
  proof(cases "n = 0")
    case True
    from sl[unfolded subseq_of_length_Suc_upt] t
    show ?thesis by (unfold nxt[unfolded inv_prevs] True set_prevs_def length_Suc_conv, auto)
  next
    case [simp]: False
    from sl[unfolded subseq_of_length_Suc_upt iis,simplified]
    have i: "i < hd is" and "is": "subseq_of_length n [0..<IArray.length tail] is" by auto
    then have *: "(hd is, v)  set_prevs base (IArray.list_of tail) n"
      by (unfold set_prevs_def, auto intro!: exI[of _ "is"] simp: v_def)
    with i have "(i, f (tail !! i) v)  {(j, f (tail !! j) v) | j. j < hd is}" by auto
    with t[unfolded iis] have "t  ..." by (auto simp: v_def)
    with * show ?thesis by (unfold nxt[unfolded inv_prevs], auto)
  qed
next
  fix t
  assume l: "t  ?l"
  from l[unfolded next_subseqs_spec(1)[OF nxt]]
  obtain j v i
  where t: "t = (j, f (tail!!j) v)"
    and j: "j < i"
    and iv: "(i,v)  set prevs" by auto
  from iv[unfolded inv_prevs set_prevs_def, simplified]
  obtain "is"
  where v: "v = foldr f (map ((!!) tail) is) base"
    and "is": "subseq_of_length n [0..<IArray.length tail] is"
    and i: "if n = 0 then i = IArray.length tail else i = hd is" by auto
  from "is" j i have jis: "subseq_of_length (Suc n) [0..<IArray.length tail] (j#is)"
    by (unfold subseq_of_length_Suc_upt, auto)
  then show "t  ?r" by (auto intro!: exI[of _ "j#is"] simp: set_prevs_def t v)
qed

lemma invariant_next_subseqs:
  assumes inv: "invariant base elements n state"
      and nxt: "next_subseqs state = (out, state')"
  shows "invariant base elements (Suc n) state'"
proof(cases "elements = []")
  case True with inv nxt show ?thesis by(cases state, auto)
next
  case False with inv nxt show ?thesis
  proof (cases state)
    case state: (fields head tail prevs)
    note inv = inv[unfolded state]
    show ?thesis
    proof (cases state')
      case state': (fields head' tail' prevs')
      note nxt = nxt[unfolded state state']
      note [simp] = next_subseq_preserve[OF nxt]
      from False inv
      have "set prevs = set_prevs base (IArray.list_of tail) n" by auto
      from False next_subseq_prevs[OF nxt this] inv
      show ?thesis by(auto simp: state')
    qed
  qed
qed

lemma out_next_subseqs:
  assumes inv: "invariant base elements n state"
      and nxt: "next_subseqs state = (out, state')"
  shows "set out = S base elements (Suc n)"
proof (cases state)
  case state: (fields head tail prevs)
  show ?thesis
  proof(cases "elements = []")
    case True
    with inv nxt show ?thesis by (auto simp: state S_def)
  next
    case elements: False
    show ?thesis
    proof(cases state')
      case state': (fields head' tail' prevs')
      from elements inv[unfolded state,simplified]
      have "head = hd elements"
       and "tail = IArray (tl elements)"
       and prevs: "set prevs = set_prevs base (tl elements) n" by auto
      with elements have elements2: "elements = head # IArray.list_of tail"  by auto
      let ?f = "λas. (foldr f as base)"
      have "set out = ?f ` {ys. subseq_of_length (Suc n) elements ys}"
      proof-
        from invariant_next_subseqs[OF inv nxt, unfolded state' invariant.simps if_not_P[OF elements]]
        have tail': "tail' = IArray (tl elements)"
         and prevs': "set prevs' = set_prevs base (tl elements) (Suc n)" by auto
        note next_subseqs_spec(2)[OF nxt[unfolded state state'], unfolded this]
        note this[folded image_comp, unfolded snd_set_prevs]
        also note prevs
        also note snd_set_prevs
        also have "f head ` ?f ` { as. subseq_of_length n (tl elements) as } =
          ?f ` Cons head ` { as. subseq_of_length n (tl elements) as }" by (auto simp: image_def)
        also note image_Un[symmetric]
        also have
          "((#) head ` {as. subseq_of_length n (tl elements) as} 
           {as. subseq_of_length (Suc n) (tl elements) as}) =
           {as. subseq_of_length (Suc n) elements as}"
        by (unfold subseqs_of_length_Suc_Cons elements2, auto)
        finally show ?thesis.
      qed
      then show ?thesis by (auto simp: S_def)
    qed
  qed
qed

lemma create_subseqs:
  "create_subseqs base elements n = (out, state) 
   invariant base elements n state  set out = S base elements n"
proof(induct n arbitrary: out state)
  case 0 then show ?case by (cases "elements", cases state, auto simp: S_def Let_def set_prevs_def)
next
  case (Suc n) show ?case
  proof (cases "create_subseqs base elements n")
    case 1: (fields out'' head tail prevs)
    show ?thesis
    proof (cases "next_subseqs (head, tail, prevs)")
      case (fields out' head' tail' prevs')
      note 2 = this[unfolded next_subseq_preserve[OF this]]
      from Suc(2)[unfolded create_subseqs.simps 1 snd_conv 2]
      have 3: "out' = out" "state = (head,tail,prevs')" by auto
      from Suc(1)[OF 1]
      have inv: "invariant base elements n (head, tail, prevs)" by auto
      from out_next_subseqs[OF inv 2] invariant_next_subseqs[OF inv 2]
      show ?thesis by (auto simp: 3)
    qed
  qed
qed

sublocale correct_subseqs_foldr_impl f impl invariant
  by (unfold_locales; auto simp: impl_def invariant_next_subseqs out_next_subseqs create_subseqs)

lemma impl_correct: "correct_subseqs_foldr_impl f impl invariant" ..
end

lemmas [code] =
  my_subseqs.next_subseqs.simps
  my_subseqs.next_subseqs1.simps
  my_subseqs.next_subseqs2.simps
  my_subseqs.create_subseqs.simps
  my_subseqs.impl_def

end

Theory Reconstruction

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Reconstruction of Integer Factorization›

text ‹We implemented Zassenhaus reconstruction-algorithm, i.e., given a factorization of $f$ mod $p^n$,
  the aim is to reconstruct a factorization of $f$ over the integers.›

theory Reconstruction
imports 
  Berlekamp_Hensel
  Polynomial_Factorization.Gauss_Lemma
  Polynomial_Factorization.Dvd_Int_Poly
  Polynomial_Factorization.Gcd_Rat_Poly
  Degree_Bound
  Factor_Bound
  Sublist_Iteration
  Poly_Mod
begin

hide_const coeff monom

paragraph ‹Misc lemmas›

lemma foldr_of_Cons[simp]: "foldr Cons xs ys = xs @ ys" by (induct xs, auto)

lemma foldr_map_prod[simp]:
  "foldr (λx. map_prod (f x) (g x)) xs base = (foldr f xs (fst base), foldr g xs (snd base))"
  by (induct xs, auto)

paragraph ‹The main part›

context poly_mod
begin

definition inv_Mp :: "int poly  int poly" where
  "inv_Mp = map_poly inv_M"
  
definition mul_const :: "int poly  int  int" where
  "mul_const p c = (coeff p 0 * c) mod m"

fun prod_list_m :: "int poly list  int poly" where
  "prod_list_m (f # fs) = Mp (f * prod_list_m fs)" 
| "prod_list_m [] = 1" 

context
  fixes sl_impl :: "(int poly, int × int poly list, 'state)subseqs_foldr_impl" 
  and m2 :: "int" 
begin
definition inv_M2 :: "int  int" where
  "inv_M2 = (λ x. if x  m2 then x else x - m)"

definition inv_Mp2 :: "int poly  int poly" where
  "inv_Mp2 = map_poly inv_M2"
  
partial_function (tailrec) reconstruction :: "'state  int poly  int poly 
   int  nat  nat  int poly list  int poly list 
   (int × (int poly list)) list  int poly list" where
  "reconstruction state u luu lu d r vs res cands = (case cands of Nil
     let d' = Suc d
      in if d' + d' > r then (u # res) else 
      (case next_subseqs_foldr sl_impl state of (cands,state') 
        reconstruction state' u luu lu d' r vs res cands)
   | (lv',ws) # cands'  let
       lv = inv_M2 lv' ― ‹lv› is last coefficient of vb› below›
     in if lv dvd coeff luu 0 then let
       vb = inv_Mp2 (Mp (smult lu (prod_list_m ws))) 
    in if vb dvd luu then 
      let pp_vb = primitive_part vb;
          u' = u div pp_vb;
          r' = r - length ws;
          res' = pp_vb # res
        in if d + d > r' 
          then u' # res'
          else let 
              lu' = lead_coeff u';
              vs' = fold remove1 ws vs;
              (cands'', state') = subseqs_foldr sl_impl (lu',[]) vs' d
            in reconstruction state' u' (smult lu' u') lu' d r' vs' res' cands''
     else reconstruction state u luu lu d r vs res cands'
     else reconstruction state u luu lu d r vs res cands')"
  end
end


declare poly_mod.reconstruction.simps[code]
declare poly_mod.prod_list_m.simps[code]
declare poly_mod.mul_const_def[code]
declare poly_mod.inv_M2_def[code]
declare poly_mod.inv_Mp2_def[code_unfold]
declare poly_mod.inv_Mp_def[code_unfold]

definition zassenhaus_reconstruction_generic :: 
  "(int poly, int × int poly list, 'state) subseqs_foldr_impl
   int poly list  int  nat  int poly  int poly list" where
  "zassenhaus_reconstruction_generic sl_impl vs p n f = (let
     lf = lead_coeff f;
     pn = p^n;
     (_, state) = subseqs_foldr sl_impl (lf,[]) vs 0
   in 
     poly_mod.reconstruction pn sl_impl (pn div 2) state f (smult lf f) lf 0 (length vs) vs [] [])"
  
lemma coeff_mult_0: "coeff (f * g) 0 = coeff f 0 * coeff g 0"
  by (metis poly_0_coeff_0 poly_mult)

lemma lead_coeff_factor: assumes u: "u = v * (w :: 'a ::idom poly)"
  shows "smult (lead_coeff u) u = (smult (lead_coeff w) v) * (smult (lead_coeff v) w)"
  "lead_coeff (smult (lead_coeff w) v) = lead_coeff u" "lead_coeff (smult (lead_coeff v) w) = lead_coeff u" 
  unfolding u by (auto simp: lead_coeff_mult lead_coeff_smult)

lemma not_irreducibled_lead_coeff_factors: assumes "¬ irreducibled (u :: 'a :: idom poly)" "degree u  0" 
  shows " f g. smult (lead_coeff u) u = f * g  lead_coeff f = lead_coeff u  lead_coeff g = lead_coeff u
   degree f < degree u  degree g < degree u" 
proof -
  from assms[unfolded irreducibled_def, simplified] 
  obtain v w where deg: "degree v < degree u" "degree w < degree u" and u: "u = v * w" by auto
  define f where "f = smult (lead_coeff w) v" 
  define g where "g = smult (lead_coeff v) w" 
  note lf = lead_coeff_factor[OF u, folded f_def g_def]
  show ?thesis
  proof (intro exI conjI, (rule lf)+)
    show "degree f < degree u" "degree g < degree u" unfolding f_def g_def using deg u by auto
  qed
qed
  
lemma mset_subseqs_size: "mset ` {ys. ys  set (subseqs xs)  length ys = n} = 
  {ws. ws ⊆# mset xs  size ws = n}" 
proof (induct xs arbitrary: n)
  case (Cons x xs n)
  show ?case (is "?l = ?r")
  proof (cases n)
    case 0
    thus ?thesis by (auto simp: Let_def)
  next
    case (Suc m)
    have "?r = {ws. ws ⊆# mset (x # xs)}  {ps. size ps = n}" by auto
    also have "{ws. ws ⊆# mset (x # xs)} = {ps. ps ⊆# mset xs}  ((λ ps. ps + {#x#}) ` {ps. ps ⊆# mset xs})"
      by (simp add: multiset_subset_insert)
    also have "  {ps. size ps = n} = {ps. ps ⊆# mset xs  size ps = n} 
       ((λ ps. ps + {#x#}) ` {ps. ps ⊆# mset xs  size ps = m})" unfolding Suc by auto
    finally have id: "?r =
      {ps. ps ⊆# mset xs  size ps = n}  (λps. ps + {#x#}) ` {ps. ps ⊆# mset xs  size ps = m}" .
    have "?l = mset ` {ys  set (subseqs xs). length ys = Suc m}
       mset ` {ys  (#) x ` set (subseqs xs). length ys = Suc m}"
      unfolding Suc by (auto simp: Let_def)
    also have "mset ` {ys  (#) x ` set (subseqs xs). length ys = Suc m}
      = (λps. ps + {#x#}) ` mset ` {ys  set (subseqs xs). length ys = m}" by force
    finally have id': "?l = mset ` {ys  set (subseqs xs). length ys = Suc m} 
      (λps. ps + {#x#}) ` mset ` {ys  set (subseqs xs). length ys = m}" .
    show ?thesis unfolding id id' Cons[symmetric] unfolding Suc by simp
  qed
qed auto

context poly_mod_2
begin
lemma prod_list_m[simp]: "prod_list_m fs = Mp (prod_list fs)" 
  by (induct fs, auto)

lemma inv_Mp_coeff: "coeff (inv_Mp f) n = inv_M (coeff f n)" 
  unfolding inv_Mp_def
  by (rule coeff_map_poly, insert m1, auto simp: inv_M_def)

lemma Mp_inv_Mp_id[simp]: "Mp (inv_Mp f) = Mp f" 
  unfolding poly_eq_iff Mp_coeff inv_Mp_coeff by simp

lemma inv_Mp_rev: assumes bnd: " n. 2 * abs (coeff f n) < m" 
  shows "inv_Mp (Mp f) = f" 
proof (rule poly_eqI)
  fix n
  define c where "c = coeff f n" 
  from bnd[of n, folded c_def] have bnd: "2 * abs c < m" by auto
  show "coeff (inv_Mp (Mp f)) n = coeff f n" unfolding inv_Mp_coeff Mp_coeff c_def[symmetric]
    using inv_M_rev[OF bnd] .
qed

lemma mul_const_commute_below: "mul_const x (mul_const y z) = mul_const y (mul_const x z)" 
    unfolding mul_const_def by (metis mod_mult_right_eq mult.left_commute)

context
  fixes p n 
    and sl_impl :: "(int poly, int × int poly list, 'state)subseqs_foldr_impl" 
    and sli :: "int × int poly list  int poly list  nat  'state  bool" 
  assumes prime: "prime p" 
  and m: "m = p^n" 
  and n: "n  0" 
  and sl_impl: "correct_subseqs_foldr_impl (λx. map_prod (mul_const x) (Cons x)) sl_impl sli"
begin
private definition "test_dvd_exec lu u ws = (¬ inv_Mp (Mp (smult lu (prod_mset ws))) dvd smult lu u)" 

private definition "test_dvd u ws = ( v l. v dvd u  0 < degree v  degree v < degree u
   ¬ v =m smult l (prod_mset ws))"

private definition "large_m u vs = ( v n. v dvd u  degree v  degree_bound vs  2 * abs (coeff v n) < m)" 

lemma large_m_factor: "large_m u vs  v dvd u  large_m v vs"
  unfolding large_m_def using dvd_trans by auto
  

lemma test_dvd_factor: assumes u: "u  0" and test: "test_dvd u ws" and vu: "v dvd u" 
  shows "test_dvd v ws" 
proof -
  from vu obtain w where uv: "u = v * w" unfolding dvd_def by auto
  from u have deg: "degree u = degree v + degree w" unfolding uv
    by (subst degree_mult_eq, auto)
  show ?thesis unfolding test_dvd_def 
  proof (intro allI impI, goal_cases)
    case (1 f l)
    from 1(1) have fu: "f dvd u" unfolding uv by auto
    from 1(3) have deg: "degree f < degree u" unfolding deg by auto
    from test[unfolded test_dvd_def, rule_format, OF fu 1(2) deg]
    show ?case .
  qed
qed

lemma coprime_exp_mod: "coprime lu p  prime p  n  0  lu mod p ^ n  0"
  by (auto simp add: abs_of_pos prime_gt_0_int)
  
interpretation correct_subseqs_foldr_impl "λx. map_prod (mul_const x) (Cons x)" sl_impl sli by fact

lemma reconstruction: assumes
    res: "reconstruction sl_impl m2 state u (smult lu u) lu d r vs res cands = fs"
  and f: "f = u * prod_list res"
  and meas: "meas = (r - d, cands)" 
  and dr: "d + d  r" 
  and r: "r = length vs" 
  and cands: "set cands  S (lu,[]) vs d"
  and d0: "d = 0  cands = []" 
  and lu: "lu = lead_coeff u" 
  and factors: "unique_factorization_m u (lu,mset vs)" 
  and sf: "poly_mod.square_free_m p u" 
  and cop: "coprime lu p"
  and norm: " v.  v  set vs  Mp v = v" 
  and tests: " ws. ws ⊆# mset vs  ws  {#}  
    size ws < d  size ws = d  ws  (mset o snd) ` set cands 
     test_dvd u ws"
  and irr: " f. f  set res  irreducibled f" 
  and deg: "degree u > 0" 
  and cands_ne: "cands  []  d < r" 
  and large: " v n. v dvd smult lu u  degree v  degree_bound vs 
     2 * abs (coeff v n) < m" 
  and f0: "f  0"
  and state: "sli (lu,[]) vs d state" 
  and m2: "m2 = m div 2" 
  shows "f = prod_list fs  ( fi  set fs. irreducibled fi)"
proof -
  from large have large: "large_m (smult lu u) vs" unfolding large_m_def by auto
  interpret p: poly_mod_prime p using prime by unfold_locales  
  define R where "R  measures [
    λ (n :: nat,cds :: (int × int poly list) list). n, 
    λ (n,cds). length cds]" 
  have wf: "wf R" unfolding R_def by simp
  have mset_snd_S: " vs lu d. (mset  snd) ` S (lu,[]) vs d = 
    { ws. ws ⊆# mset vs  size ws = d}"
    by (fold mset_subseqs_size image_comp, unfold S_def image_Collect, auto)
  have inv_M2[simp]: "inv_M2 m2 = inv_M" unfolding inv_M2_def m2 inv_M_def
    by (intro ext, auto)
  have inv_Mp2[simp]: "inv_Mp2 m2 = inv_Mp" unfolding inv_Mp2_def inv_Mp_def by simp
  have p_Mp[simp]: " f. p.Mp (Mp f) = p.Mp f" using m p.m1 n Mp_Mp_pow_is_Mp by blast
  {
    fix u lu vs
    assume eq: "Mp u = Mp (smult lu (prod_mset vs))" and cop: "coprime lu p" and size: "size vs  0"
      and mi: " v. v ∈# vs  irreducibled_m v  monic v"     
    from cop p.m1 have lu0: "lu  0" by auto
    from size have "vs  {#}" by auto
    then obtain v vs' where vs_v: "vs = vs' + {#v#}" by (cases vs, auto)
    have mon: "monic (prod_mset vs)" 
      by (rule monic_prod_mset, insert mi, auto)
    hence vs0: "prod_mset vs  0" by (metis coeff_0 zero_neq_one)
    from mon have l_vs: "lead_coeff (prod_mset vs) = 1" .
    have deg_ws: "degree_m (smult lu (prod_mset vs)) = degree (smult lu (prod_mset vs))"
      by (rule degree_m_eq[OF _ m1], unfold lead_coeff_smult,
      insert cop n p.m1 l_vs, auto simp: m)
    with eq have "degree_m u = degree (smult lu (prod_mset vs))" by auto
    also have " = degree (prod_mset vs' * v)" unfolding degree_smult_eq vs_v using lu0 by (simp add:ac_simps)
    also have " = degree (prod_mset vs') + degree v" 
      by (rule degree_mult_eq, insert vs0[unfolded vs_v], auto)
    also have "  degree v" by simp
    finally have deg_v: "degree v  degree_m u" .
    from mi[unfolded vs_v, of v] have "irreducibled_m v" by auto
    hence "0 < degree_m v" unfolding irreducibled_m_def by auto
    also have "  degree v" by (rule degree_m_le)
    also have "  degree_m u" by (rule deg_v)
    also have "  degree u" by (rule degree_m_le)
    finally have "degree u > 0" by auto
  } note deg_non_zero = this
  {
    fix u :: "int poly" and vs :: "int poly list" and d :: nat
    assume deg_u: "degree u > 0"
    and cop: "coprime (lead_coeff u) p"
    and uf: "unique_factorization_m u (lead_coeff u, mset vs)" 
    and sf: "p.square_free_m u"
    and norm: " v. v  set vs  Mp v = v"
    and d: "size (mset vs) < d + d"
    and tests: " ws. ws ⊆# mset vs  ws  {#}  size ws < d  test_dvd u ws" 
    from deg_u have u0: "u  0" by auto
    have "irreducibled u"
    proof (rule irreducibledI[OF deg_u])
      fix q q' :: "int poly"
      assume deg: "degree q > 0" "degree q < degree u" "degree q' > 0" "degree q' < degree u"
         and uq: "u = q * q'"
      then have qu: "q dvd u" and q'u: "q' dvd u" by auto
      from u0 have deg_u: "degree u = degree q + degree q'" unfolding uq 
        by (subst degree_mult_eq, auto)
      from coprime_lead_coeff_factor[OF prime cop[unfolded uq]]
      have cop_q: "coprime (lead_coeff q) p" "coprime (lead_coeff q') p" by auto
      from unique_factorization_m_factor[OF prime uf[unfolded uq] _ _ n m, folded uq, 
        OF cop sf]          
      obtain fs gs l where uf_q: "unique_factorization_m q (lead_coeff q, fs)"
        and uf_q': "unique_factorization_m q' (lead_coeff q', gs)"
        and Mf_eq: "Mf (l, mset vs) = Mf (lead_coeff q * lead_coeff q', fs + gs)" 
        and fs_id: "image_mset Mp fs = fs" 
        and gs_id: "image_mset Mp gs = gs" by auto
      from Mf_eq fs_id gs_id have "image_mset Mp (mset vs) = fs + gs" 
        unfolding Mf_def by auto
      also have "image_mset Mp (mset vs) = mset vs" using norm by (induct vs, auto)
      finally have eq: "mset vs = fs + gs" by simp
      from uf_q[unfolded unique_factorization_m_alt_def factorization_m_def split]
      have q_eq: "q =m smult (lead_coeff q) (prod_mset fs)" by auto
      have "degree_m q = degree q" 
        by (rule degree_m_eq[OF _ m1], insert cop_q(1) n p.m1, unfold m, 
          auto simp:)
      with q_eq have degm_q: "degree q = degree (Mp (smult (lead_coeff q) (prod_mset fs)))" by auto
      with deg have fs_nempty: "fs  {#}" 
        by (cases fs; cases "lead_coeff q = 0"; auto simp: Mp_def)
      from uf_q'[unfolded unique_factorization_m_alt_def factorization_m_def split]
      have q'_eq: "q' =m smult (lead_coeff q') (prod_mset gs)" by auto
      have "degree_m q' = degree q'" 
        by (rule degree_m_eq[OF _ m1], insert cop_q(2) n p.m1, unfold m, 
          auto simp:)
      with q'_eq have degm_q': "degree q' = degree (Mp (smult (lead_coeff q') (prod_mset gs)))" by auto
      with deg have gs_nempty: "gs  {#}" 
        by (cases gs; cases "lead_coeff q' = 0"; auto simp: Mp_def)
  
      from eq have size: "size fs + size gs = size (mset vs)" by auto
      with d have choice: "size fs < d  size gs < d" by auto
      from choice show False
      proof
        assume fs: "size fs < d" 
        from eq have sub: "fs ⊆# mset vs" using mset_subset_eq_add_left[of fs gs] by auto
        have "test_dvd u fs"
          by (rule tests[OF sub fs_nempty, unfolded Nil], insert fs, auto)
        from this[unfolded test_dvd_def] uq deg q_eq show False by auto
      next
        assume gs: "size gs < d"
        from eq have sub: "gs ⊆# mset vs" using mset_subset_eq_add_left[of fs gs] by auto
        have "test_dvd u gs"
          by (rule tests[OF sub gs_nempty, unfolded Nil], insert gs, auto)
        from this[unfolded test_dvd_def] uq deg q'_eq show False unfolding uq by auto
      qed
    qed
  } note irreducibled_via_tests = this
  show ?thesis using assms(1-16) large state
  proof (induct meas arbitrary: u lu d r vs res cands state rule: wf_induct[OF wf])
    case (1 meas u lu d r vs res cands state)
    note IH = 1(1)[rule_format]
    note res = 1(2)[unfolded reconstruction.simps[where cands = cands]]
    note f = 1(3)
    note meas = 1(4)
    note dr = 1(5)
    note r = 1(6)
    note cands = 1(7)
    note d0 = 1(8)
    note lu = 1(9)
    note factors = 1(10)
    note sf = 1(11)
    note cop = 1(12)
    note norm = 1(13)
    note tests = 1(14)
    note irr = 1(15)
    note deg_u = 1(16)
    note cands_empty = 1(17)
    note large = 1(18)
    note state = 1(19)
    from unique_factorization_m_zero[OF factors] 
    have Mlu0: "M lu  0" by auto
    from Mlu0 have lu0: "lu  0" by auto
    from this[unfolded lu] have u0: "u  0" by auto
    from unique_factorization_m_imp_factorization[OF factors]
    have fact: "factorization_m u (lu,mset vs)" by auto
    from this[unfolded factorization_m_def split] norm
    have vs: "u =m smult lu (prod_list vs)" and 
      vs_mi: " f. f∈#mset vs  irreducibled_m f  monic f" by auto
    let ?luu = "smult lu u" 
    show ?case
    proof (cases cands)
      case Nil
      note res = res[unfolded this]
      let ?d' = "Suc d"
      show ?thesis
      proof (cases "r < ?d' + ?d'")
        case True
        with res have fs: "fs = u # res" by (simp add: Let_def)
        from True[unfolded r] have size: "size (mset vs) < ?d' + ?d'" by auto
        have "irreducibled u" 
          by (rule irreducibled_via_tests[OF deg_u cop[unfolded lu] factors(1)[unfolded lu] 
          sf norm size tests], auto simp: Nil)
        with fs f irr show ?thesis by simp
      next
        case False
        with dr have dr: "?d' + ?d'  r" and dr': "?d' < r" by auto
        obtain state' cands' where sln: "next_subseqs_foldr sl_impl state = (cands',state')" by force
        from next_subseqs_foldr[OF sln state] have state': "sli (lu,[]) vs (Suc d) state'"
          and cands': "set cands' = S (lu,[]) vs (Suc d)" by auto
        let ?new = "subseqs_length mul_const lu ?d' vs" 
        have R: "((r - Suc d, cands'), meas)  R" unfolding meas R_def using False by auto
        from res False sln
        have fact: "reconstruction sl_impl m2 state' u ?luu lu ?d' r vs res cands' = fs" by auto
        show ?thesis 
        proof (rule IH[OF R fact f refl dr r _ _ lu factors sf cop norm _ irr deg_u dr' large state'], goal_cases) 
          case (4 ws)
          show ?case
          proof (cases "size ws = Suc d")
            case False
            with 4 have "size ws < Suc d" by auto
            thus ?thesis by (intro tests[OF 4(1-2)], unfold Nil, auto)
          next
            case True
            from 4(3)[unfolded cands' mset_snd_S] True 4(1) show ?thesis by auto
          qed
        qed (auto simp: cands')
      qed
    next
      case (Cons c cds)
      with d0 have d0: "d > 0" by auto
      obtain lv' ws where c: "c = (lv',ws)" by force
      let ?lv = "inv_M lv'" 
      define vb where "vb  inv_Mp (Mp (smult lu (prod_list ws)))" 
      note res = res[unfolded Cons c list.simps split]
      from cands[unfolded Cons c S_def] have ws: "ws  set (subseqs vs)" "length ws = d" 
        and lv'': "lv' = foldr mul_const ws lu" by auto
      from subseqs_sub_mset[OF ws(1)] have ws_vs: "mset ws ⊆# mset vs" "set ws  set vs" 
        using set_mset_mono subseqs_length_simple_False by auto fastforce
      have mon_ws: "monic (prod_mset (mset ws))" 
        by (rule monic_prod_mset, insert ws_vs vs_mi, auto) 
      have l_ws: "lead_coeff (prod_mset (mset ws)) = 1" using mon_ws .
      have lv': "M lv' = M (coeff (smult lu (prod_list ws)) 0)" 
        unfolding lv'' coeff_smult
        by (induct ws arbitrary: lu, auto simp: mul_const_def M_def coeff_mult_0)
           (metis mod_mult_right_eq mult.left_commute)
      show ?thesis
      proof (cases "?lv dvd coeff ?luu 0  vb dvd ?luu")
        case False
        have ndvd: "¬ vb dvd ?luu" 
        proof
          assume dvd: "vb dvd ?luu" 
          hence "coeff vb 0 dvd coeff ?luu 0" by (metis coeff_mult_0 dvd_def)
          with dvd False have "?lv  coeff vb 0" by auto
          also have "lv' = M lv'" using ws(2) d0 unfolding lv''
            by (cases ws, force, simp add: M_def mul_const_def)
          also have "inv_M (M lv') = coeff vb 0" unfolding vb_def inv_Mp_coeff Mp_coeff lv' by simp 
          finally show False by simp
        qed
        from False res 
        have res: "reconstruction sl_impl m2 state u ?luu lu d r vs res cds = fs" 
          unfolding vb_def Let_def by auto
        have R: "((r - d, cds), meas)  R" unfolding meas Cons R_def by auto
        from cands have cands: "set cds  S (lu,[]) vs d" 
          unfolding Cons by auto
        show ?thesis
        proof (rule IH[OF R res f refl dr r cands _ lu factors sf cop norm _ irr deg_u _ large state], goal_cases) 
          case (3 ws')
          show ?case 
          proof (cases "ws' = mset ws")
            case False
            show ?thesis
              by (rule tests[OF 3(1-2)], insert 3(3) False, force simp: Cons c)
          next
            case True
            have test: "test_dvd_exec lu u ws'"
              unfolding True test_dvd_exec_def using ndvd unfolding vb_def by simp
            show ?thesis unfolding test_dvd_def
            proof (intro allI impI notI, goal_cases)
              case (1 v l)
              note deg_v = 1(2-3)
              from 1(1) obtain w where u: "u = v * w" unfolding dvd_def by auto
              from u0 have deg: "degree u = degree v + degree w" unfolding u 
                by (subst degree_mult_eq, auto)
              define v' where "v' = smult (lead_coeff w) v" 
              define w' where "w' = smult (lead_coeff v) w" 
              let ?ws = "smult (lead_coeff w * l) (prod_mset ws')" 
              from arg_cong[OF 1(4), of "λ f. Mp (smult (lead_coeff w) f)"]
              have v'_ws': "Mp v' = Mp ?ws" unfolding v'_def 
                by simp
              from lead_coeff_factor[OF u, folded v'_def w'_def]
              have prod: "?luu = v' * w'" and lc: "lead_coeff v' = lu" and "lead_coeff w' = lu"
                unfolding lu by auto
              with lu0 have lc0: "lead_coeff v  0" "lead_coeff w  0" unfolding v'_def w'_def by auto
              from deg_v have deg_w: "0 < degree w" "degree w < degree u" unfolding deg by auto
              from deg_v deg_w lc0 
              have deg: "0 < degree v'" "degree v' < degree u" "0 < degree w'" "degree w' < degree u" 
                unfolding v'_def w'_def by auto
              from prod have v_dvd: "v' dvd ?luu" by auto
              with test[unfolded test_dvd_exec_def] 
              have neq: "v'  inv_Mp (Mp (smult lu (prod_mset ws')))" by auto
              have deg_m_v': "degree_m v' = degree v'" 
                by (rule degree_m_eq[OF _ m1], unfold lc m, 
                insert cop prime n coprime_exp_mod, auto)
              with v'_ws' have "degree v' = degree_m ?ws" by simp
              also have "  degree_m (prod_mset ws')" by (rule degree_m_smult_le)
              also have " = degree_m (prod_list ws)" unfolding True by simp
              also have "  degree (prod_list ws)" by (rule degree_m_le)
              also have "  degree_bound vs" 
                using ws_vs(1) ws(2) dr[unfolded r] degree_bound by auto
              finally have "degree v'  degree_bound vs" .
              from inv_Mp_rev[OF large[unfolded large_m_def, rule_format, OF v_dvd this]]
              have inv: "inv_Mp (Mp v') = v'" by simp
              from arg_cong[OF v'_ws', of inv_Mp, unfolded inv]
              have v': "v' = inv_Mp (Mp ?ws)" by auto
              have deg_ws: "degree_m ?ws = degree ?ws" 
              proof (rule degree_m_eq[OF _ m1], 
                unfold lead_coeff_smult True l_ws, rule)
                assume "lead_coeff w * l * 1 mod m = 0" 
                hence 0: "M (lead_coeff w * l) = 0" unfolding M_def by simp
                have "Mp ?ws = Mp (smult (M (lead_coeff w * l)) (prod_mset ws'))" by simp
                also have " = 0" unfolding 0 by simp
                finally have "Mp ?ws = 0" by simp
                hence "v' = 0" unfolding v' by (simp add: inv_Mp_def)
                with deg show False by auto
              qed
              from arg_cong[OF v', of "λ f. lead_coeff (Mp f)", simplified] 
              have "M lu = M (lead_coeff v')" using lc by simp
              also have " = lead_coeff (Mp v')" 
                by (rule degree_m_eq_lead_coeff[OF deg_m_v', symmetric])
              also have " = lead_coeff (Mp ?ws)" 
                using arg_cong[OF v', of "λ f. lead_coeff (Mp f)"] by simp
              also have " = M (lead_coeff ?ws)"
                by (rule degree_m_eq_lead_coeff[OF deg_ws])
              also have " = M (lead_coeff w * l)" unfolding lead_coeff_smult True l_ws by simp
              finally have id: "M lu = M (lead_coeff w * l)" .
              note v'
              also have "Mp ?ws = Mp (smult (M (lead_coeff w * l)) (prod_mset ws'))" by simp
              also have " = Mp (smult lu (prod_mset ws'))" unfolding id[symmetric] by simp
              finally show False using neq by simp 
            qed
          qed
        qed (insert d0 Cons cands_empty, auto)
      next
        case True
        define pp_vb where "pp_vb  primitive_part vb" 
        define u' where "u'  u div pp_vb"
        define lu' where "lu'  lead_coeff u'" 
        let ?luu' = "smult lu' u'" 
        define vs' where "vs'  fold remove1 ws vs" 
        obtain state' cands' where slc: "subseqs_foldr sl_impl (lu',[]) vs' d = (cands', state')" by force
        from subseqs_foldr[OF slc] have state': "sli (lu',[]) vs' d state'"
          and cands': "set cands' = S (lu',[]) vs' d" by auto
        let ?res' = "pp_vb # res" 
        let ?r' = "r - length ws" 
        note defs = vb_def pp_vb_def u'_def lu'_def vs'_def slc
        from fold_remove1_mset[OF subseqs_sub_mset[OF ws(1)]]
        have vs_split: "mset vs = mset vs' + mset ws" unfolding vs'_def by auto
        hence vs'_diff: "mset vs' = mset vs - mset ws" and ws_sub: "mset ws ⊆# mset vs" by auto
        from arg_cong[OF vs_split, of size]
        have r': "?r' = length vs'" unfolding defs r by simp
        from arg_cong[OF vs_split, of prod_mset] 
        have prod_vs: "prod_list vs = prod_list vs' * prod_list ws" by simp
        from arg_cong[OF vs_split, of set_mset] have set_vs: "set vs = set vs'  set ws" by auto
        note inv = inverse_mod_coprime_exp[OF m prime n]
        note p_inv = p.inverse_mod_coprime[OF prime]
        from True res slc
        have res: "(if ?r' < d + d then u' # ?res' else reconstruction sl_impl m2 state'
          u' ?luu' lu' d ?r' vs' ?res' cands') = fs" 
           unfolding Let_def defs by auto
        from True have dvd: "vb dvd ?luu" by simp
        from dvd_smult_int[OF lu0 this] have ppu: "pp_vb dvd u" unfolding defs by simp
        hence u: "u = pp_vb * u'" unfolding u'_def
          by (metis dvdE mult_eq_0_iff nonzero_mult_div_cancel_left)
        hence uu': "u' dvd u" unfolding dvd_def by auto
        have f: "f = u' * prod_list ?res'" using f u by auto
        let ?fact = "smult lu (prod_mset (mset ws))" 
        have Mp_vb: "Mp vb = Mp (smult lu (prod_list ws))"  unfolding vb_def by simp
        have pp_vb_vb: "smult (content vb) pp_vb = vb" unfolding pp_vb_def by (rule content_times_primitive_part)
        {
          have "smult (content vb) u = (smult (content vb) pp_vb) * u'" unfolding u by simp
          also have "smult (content vb) pp_vb = vb" by fact
          finally have "smult (content vb) u = vb * u'" by simp
          from arg_cong[OF this, of Mp]
          have "Mp (Mp vb * u') = Mp (smult (content vb) u)" by simp
          hence "Mp (smult (content vb) u) = Mp (?fact * u')" unfolding Mp_vb by simp
        } note prod = this
        from arg_cong[OF this, of p.Mp]
        have prod': "p.Mp (smult (content vb) u) = p.Mp (?fact * u')" by simp
        from dvd have "lead_coeff vb dvd lead_coeff (smult lu u)" 
          by (metis dvd_def lead_coeff_mult)
        hence ldvd: "lead_coeff vb dvd lu * lu" unfolding lead_coeff_smult lu by simp
        from cop have cop_lu: "coprime (lu * lu) p"
          by simp
        from coprime_divisors [OF ldvd dvd_refl] cop_lu
        have cop_lvb: "coprime (lead_coeff vb) p" by simp
        then have cop_vb: "coprime (content vb) p" 
          by (auto intro: coprime_divisors[OF content_dvd_coeff dvd_refl])
        from u have "u' dvd u" unfolding dvd_def by auto
        hence "lead_coeff u' dvd lu" unfolding lu by (metis dvd_def lead_coeff_mult)
        from coprime_divisors[OF this dvd_refl] cop
        have "coprime (lead_coeff u') p" by simp
        hence "coprime (lu * lead_coeff u') p" and cop_lu': "coprime lu' p" 
          using cop by (auto simp: lu'_def)
        hence cop': "coprime (lead_coeff (?fact * u')) p" 
          unfolding lead_coeff_mult lead_coeff_smult l_ws by simp
        have "p.square_free_m (smult (content vb) u)" using cop_vb sf p_inv
          by (auto intro!: p.square_free_m_smultI)
        from p.square_free_m_cong[OF this prod']
        have sf': "p.square_free_m (?fact * u')" by simp
        from p.square_free_m_factor[OF this] 
        have sf_u': "p.square_free_m u'" by simp
        have "unique_factorization_m (smult (content vb) u) (lu * content vb, mset vs)"
          using cop_vb factors inv by (auto intro: unique_factorization_m_smult)
        from unique_factorization_m_cong[OF this prod]
        have uf: "unique_factorization_m (?fact * u') (lu * content vb, mset vs)" .
        {
          from unique_factorization_m_factor[OF prime uf cop' sf' n m] 
          obtain fs gs where uf1: "unique_factorization_m ?fact (lu, fs)"
            and uf2: "unique_factorization_m u' (lu', gs)"
            and eq: "Mf (lu * content vb, mset vs) = Mf (lu * lead_coeff u', fs + gs)" 
            unfolding lead_coeff_smult l_ws lu'_def
            by auto
          have "factorization_m ?fact (lu, mset ws)"
            unfolding factorization_m_def split using set_vs vs_mi norm by auto
          with uf1[unfolded unique_factorization_m_alt_def] have "Mf (lu,mset ws) = Mf (lu, fs)"
            by blast
          hence fs_ws: "image_mset Mp fs = image_mset Mp (mset ws)" unfolding Mf_def split by auto
          from eq[unfolded Mf_def split] 
          have "image_mset Mp (mset vs) = image_mset Mp fs + image_mset Mp gs" by auto
          from this[unfolded fs_ws vs_split] have gs: "image_mset Mp gs = image_mset Mp (mset vs')"
            by (simp add: ac_simps)
          from uf1 have uf1: "unique_factorization_m ?fact (lu, mset ws)" 
            unfolding unique_factorization_m_def Mf_def split fs_ws by simp
          from uf2 have uf2: "unique_factorization_m u' (lu', mset vs')" 
            unfolding unique_factorization_m_def Mf_def split gs by simp
          note uf1 uf2
        }
        hence factors: "unique_factorization_m u' (lu', mset vs')" 
          "unique_factorization_m ?fact (lu, mset ws)" by auto
        have lu': "lu' = lead_coeff u'" unfolding lu'_def by simp
        have vb0: "vb  0" using dvd lu0 u0 by auto        
        from ws(2) have size_ws: "size (mset ws) = d" by auto
        with d0 have size_ws0: "size (mset ws)  0" by auto
        then obtain w ws' where ws_w: "ws = w # ws'" by (cases ws, auto)
        from Mp_vb have Mp_vb': "Mp vb = Mp (smult lu (prod_mset (mset ws)))" by auto
        have deg_vb: "degree vb > 0"
          by (rule deg_non_zero[OF Mp_vb' cop size_ws0 vs_mi], insert vs_split, auto)
        also have "degree vb = degree pp_vb" using arg_cong[OF pp_vb_vb, of degree]
          unfolding degree_smult_eq using vb0 by auto
        finally have deg_pp: "degree pp_vb > 0" by auto
        hence pp_vb0: "pp_vb  0" by auto
        from factors(1)[unfolded unique_factorization_m_alt_def factorization_m_def]
        have eq_u': "Mp u' = Mp (smult lu' (prod_mset (mset vs')))" by auto 
        from r'[unfolded ws(2)] dr have "length vs' + d = r" by auto
        from this cands_empty[unfolded Cons] have "size (mset vs')  0" by auto
        from deg_non_zero[OF eq_u' cop_lu' this vs_mi] 
        have deg_u': "degree u' > 0" unfolding vs_split by auto
        have irr_pp: "irreducibled pp_vb" 
        proof (rule irreducibledI[OF deg_pp])
          fix q r :: "int poly"
          assume deg_q: "degree q > 0" "degree q < degree pp_vb"
            and deg_r:  "degree r > 0" "degree r < degree pp_vb"
            and pp_qr: "pp_vb = q * r"
          then have qvb: "q dvd pp_vb" by auto
          from dvd_trans[OF qvb ppu] have qu: "q dvd u" .
          have "degree pp_vb = degree q + degree r" unfolding pp_qr
            by (subst degree_mult_eq, insert pp_qr pp_vb0, auto)
          have uf: "unique_factorization_m (smult (content vb) pp_vb) (lu, mset ws)" 
            unfolding pp_vb_vb
            by (rule unique_factorization_m_cong[OF factors(2)], insert Mp_vb, auto)
          from unique_factorization_m_smultD[OF uf inv] cop_vb
          have uf: "unique_factorization_m pp_vb (lu * inverse_mod (content vb) m, mset ws)" by auto
          from ppu have "lead_coeff pp_vb dvd lu" unfolding lu by (metis dvd_def lead_coeff_mult)
          from coprime_divisors[OF this dvd_refl] cop
          have cop_pp: "coprime (lead_coeff pp_vb) p" by simp
          from coprime_lead_coeff_factor[OF prime cop_pp[unfolded pp_qr]]
          have cop_qr: "coprime (lead_coeff q) p" "coprime (lead_coeff r) p" by auto
          from p.square_free_m_factor[OF sf[unfolded u]]
          have sf_pp: "p.square_free_m pp_vb" by simp
          from unique_factorization_m_factor[OF prime uf[unfolded pp_qr] _ _ n m, 
            folded pp_qr, OF cop_pp sf_pp]
          obtain fs gs l where uf_q: "unique_factorization_m q (lead_coeff q, fs)"
            and uf_r: "unique_factorization_m r (lead_coeff r, gs)"
            and Mf_eq: "Mf (l, mset ws) = Mf (lead_coeff q * lead_coeff r, fs + gs)" 
            and fs_id: "image_mset Mp fs = fs" 
            and gs_id: "image_mset Mp gs = gs" by auto
          from Mf_eq have "image_mset Mp (mset ws) = image_mset Mp fs + image_mset Mp gs" 
            unfolding Mf_def by auto
          also have "image_mset Mp (mset ws) = mset ws" using norm ws_vs(2) by (induct ws, auto)
          finally have eq: "mset ws = image_mset Mp fs + image_mset Mp gs" by simp
          from arg_cong[OF this, of size, unfolded size_ws] have size: "size fs + size gs = d" by auto
          from uf_q[unfolded unique_factorization_m_alt_def factorization_m_def split]
          have q_eq: "q =m smult (lead_coeff q) (prod_mset fs)" by auto
          have "degree_m q = degree q" 
            by (rule degree_m_eq[OF _ m1], insert cop_qr(1) n p.m1, unfold m, 
              auto simp:)
          with q_eq have degm_q: "degree q = degree (Mp (smult (lead_coeff q) (prod_mset fs)))" by auto
          with deg_q have fs_nempty: "fs  {#}" 
            by (cases fs; cases "lead_coeff q = 0"; auto simp: Mp_def)
          from uf_r[unfolded unique_factorization_m_alt_def factorization_m_def split]
          have r_eq: "r =m smult (lead_coeff r) (prod_mset gs)" by auto
          have "degree_m r = degree r" 
            by (rule degree_m_eq[OF _ m1], insert cop_qr(2) n p.m1, unfold m, 
              auto simp:)
          with r_eq have degm_r: "degree r = degree (Mp (smult (lead_coeff r) (prod_mset gs)))" by auto
          with deg_r have gs_nempty: "gs  {#}" 
            by (cases gs; cases "lead_coeff r = 0"; auto simp: Mp_def)
          from gs_nempty have "size gs  0" by auto
          with size have size_fs: "size fs < d" by linarith
          note * = tests[unfolded test_dvd_def, rule_format, OF _ fs_nempty _ qu, of "lead_coeff q"]
          from ppu have "degree pp_vb  degree u"
            using dvd_imp_degree_le u0 by blast
          with deg_q q_eq size_fs
          have "¬ fs ⊆# mset vs" by (auto dest!:*)
          thus False unfolding vs_split eq fs_id gs_id using mset_subset_eq_add_left[of fs "mset vs' + gs"] 
            by (auto simp: ac_simps)
        qed
        {
          fix ws'
          assume *: "ws' ⊆# mset vs'" "ws'  {#}" 
            "size ws' < d  size ws' = d  ws'  (mset  snd) ` set cands'"
          from *(1) have "ws' ⊆# mset vs" unfolding vs_split 
            by (simp add: subset_mset.add_increasing2)
          from tests[OF this *(2)] *(3)[unfolded cands' mset_snd_S] *(1)
          have "test_dvd u ws'" by auto
          from test_dvd_factor[OF u0 this[unfolded lu] uu']
          have "test_dvd u' ws'" .
        } note tests' = this
        show ?thesis
        proof (cases "?r' < d + d")
          case True
          with res have res: "fs = u' # ?res'" by auto
          from True r' have size: "size (mset vs') < d + d" by auto
          have "irreducibled u'" 
            by (rule irreducibled_via_tests[OF deg_u' cop_lu'[unfolded lu'] factors(1)[unfolded lu'] 
            sf_u' norm size tests'], insert set_vs, auto)
          with f res irr irr_pp show ?thesis by auto
        next
          case False
          have res: "reconstruction sl_impl m2 state' u' ?luu' lu' d ?r' vs' ?res' cands' = fs" 
            using False res by auto
          from False have dr: "d + d  ?r'" by auto
          from False dr r r' d0 ws Cons have le: "?r' - d < r - d" by (cases ws, auto)
          hence R: "((?r' - d, cands'), meas)  R" unfolding meas R_def by simp
          have dr': "d < ?r'" using le False ws(2) by linarith 
          have luu': "lu' dvd lu" using ‹lead_coeff u' dvd lu unfolding lu' .
          have "large_m (smult lu' u') vs" 
            by (rule large_m_factor[OF large dvd_dvd_smult], insert uu' luu') 
          moreover have "degree_bound vs'  degree_bound vs" 
            unfolding vs'_def degree_bound_def by (rule max_factor_degree_mono)
          ultimately have large': "large_m (smult lu' u') vs'" unfolding large_m_def by auto
          show ?thesis   
            by (rule IH[OF R res f refl dr r' _ _ lu' factors(1) sf_u' cop_lu' norm tests' _ deg_u' 
            dr' large' state'], insert irr irr_pp d0 Cons set_vs, auto simp: cands')
        qed
      qed
    qed
  qed
qed
end
end

(* select implementation of subseqs *)
definition zassenhaus_reconstruction :: 
  "int poly list  int  nat  int poly  int poly list" where
  "zassenhaus_reconstruction vs p n f = (let
     mul = poly_mod.mul_const (p^n);
     sl_impl = my_subseqs.impl (λx. map_prod (mul x) (Cons x))
     in zassenhaus_reconstruction_generic sl_impl vs p n f)" 

context
  fixes p n f hs
  assumes prime: "prime p" 
  and cop: "coprime (lead_coeff f) p"
  and sf: "poly_mod.square_free_m p f"
  and deg: "degree f > 0" 
  and bh: "berlekamp_hensel p n f = hs" 
  and bnd: "2 * ¦lead_coeff f¦ * factor_bound f (degree_bound hs) < p ^ n" 
begin

private lemma n: "n  0" 
proof
  assume n: "n = 0" 
  hence pn: "p^n = 1" by auto  
  let ?f = "smult (lead_coeff f) f" 
  let ?d = "degree_bound hs" 
  have f: "f  0" using deg by auto
  hence "lead_coeff f  0" by auto
  hence lf: "abs (lead_coeff f) > 0" by auto
  obtain c d where c: "factor_bound f (degree_bound hs) = c" "abs (lead_coeff f) = d" by auto
  {
    assume *: "1  c" "2 * d * c < 1" "0 < d" 
    hence "1  d" by auto
    from mult_mono[OF this *(1)] * have "1  d * c" by auto
    hence "2 * d * c  2" by auto
    with * have False by auto
  } note tedious = this 
  have "1  factor_bound f ?d" 
    using factor_bound[OF f, of 1 ?d 0] by auto
  also have " = 0" using bnd unfolding pn 
    using factor_bound_ge_0[of f "degree_bound hs", OF f] lf unfolding c
    by (cases "c  1"; insert tedious, auto)
  finally show False by simp
qed

interpretation p: poly_mod_prime p using prime by unfold_locales

lemma zassenhaus_reconstruction_generic:
  assumes sl_impl: "correct_subseqs_foldr_impl (λv. map_prod (poly_mod.mul_const (p^n) v) (Cons v)) sl_impl sli"
  and res: "zassenhaus_reconstruction_generic sl_impl hs p n f = fs" 
  shows "f = prod_list fs  ( fi  set fs. irreducibled fi)"
proof -
  let ?lc = "lead_coeff f" 
  let ?ff = "smult ?lc f" 
  let ?q = "p^n" 
  have p1: "p > 1" using prime unfolding prime_int_iff by simp
  interpret poly_mod_2 "p^n" using p1 n unfolding poly_mod_2_def by simp
  obtain cands state where slc: "subseqs_foldr sl_impl (lead_coeff f, []) hs 0 = (cands, state)" by force
  interpret correct_subseqs_foldr_impl "λx. map_prod (mul_const x) (Cons x)" sl_impl sli by fact
  from subseqs_foldr[OF slc] have state: "sli (lead_coeff f, []) hs 0 state" by auto
  from res[unfolded zassenhaus_reconstruction_generic_def bh split Let_def slc fst_conv]
  have res: "reconstruction sl_impl (?q div 2) state f ?ff ?lc 0 (length hs) hs [] [] = fs" by auto
  from p.berlekamp_hensel_unique[OF cop sf bh n]
  have ufact: "unique_factorization_m f (?lc, mset hs)" by simp
  note bh = p.berlekamp_hensel[OF cop sf bh n]
  from deg have f0: "f  0" and lf0: "?lc  0" by auto
  hence ff0: "?ff  0" by auto
  have bnd: "g k. g dvd ?ff  degree g  degree_bound hs  2 * ¦coeff g k¦ < p ^ n"
  proof (intro allI impI, goal_cases)
    case (1 g k)
    from factor_bound_smult[OF f0 lf0 1, of k] 
    have "¦coeff g k¦  ¦?lc¦ * factor_bound f (degree_bound hs)" .
    hence "2 * ¦coeff g k¦  2 * ¦?lc¦ * factor_bound f (degree_bound hs)" by auto
    also have " < p^n" using bnd .
    finally show ?case .
  qed
  note bh' = bh[unfolded factorization_m_def split]
  have deg_f: "degree_m f = degree f"
    using cop unique_factorization_m_zero [OF ufact] n
    by (auto simp add: M_def intro: degree_m_eq [OF _ m1])
  have mon_hs: "monic (prod_list hs)" using bh' by (auto intro: monic_prod_list)
  have Mlc: "M ?lc  {1 ..< p^n}" 
    by (rule prime_cop_exp_poly_mod[OF prime cop n])
  hence "?lc  0" by auto
  hence f0: "f  0" by auto
  have degm: "degree_m (smult ?lc (prod_list hs)) = degree (smult ?lc (prod_list hs))" 
    by (rule degree_m_eq[OF _ m1], insert n bh mon_hs Mlc, auto simp: M_def)
  from reconstruction[OF prime refl n sl_impl res _ refl _ refl _ refl refl ufact sf 
      cop _ _ _ deg _ bnd f0] bh(2) state
  show ?thesis by simp
qed

lemma zassenhaus_reconstruction_irreducibled:
  assumes res: "zassenhaus_reconstruction hs p n f = fs"
  shows "f = prod_list fs  ( fi  set fs. irreducibled fi)" 
  by (rule zassenhaus_reconstruction_generic[OF my_subseqs.impl_correct 
      res[unfolded zassenhaus_reconstruction_def Let_def]])

corollary zassenhaus_reconstruction:
  assumes pr: "primitive f"
  assumes res: "zassenhaus_reconstruction hs p n f = fs"
  shows "f = prod_list fs  ( fi  set fs. irreducible fi)"
  using zassenhaus_reconstruction_irreducibled[OF res] pr
    irreducible_primitive_connect[OF primitive_prod_list]
    by auto
end

end

Theory Code_Abort_Gcd

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
theory Code_Abort_Gcd
imports   
  "HOL-Computational_Algebra.Polynomial_Factorial"
begin

text ‹Dummy code-setup for @{const Gcd} and @{const Lcm} in the presence of 
  Container.›

definition dummy_Gcd where "dummy_Gcd x = Gcd x" 
definition dummy_Lcm where "dummy_Lcm x = Lcm x" 
declare  [[code abort: dummy_Gcd]]

lemma dummy_Gcd_Lcm: "Gcd x = dummy_Gcd x" "Lcm x = dummy_Lcm x" 
  unfolding dummy_Gcd_def dummy_Lcm_def by auto

lemmas dummy_Gcd_Lcm_poly [code] = dummy_Gcd_Lcm
  [where ?'a = "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"] 
lemmas dummy_Gcd_Lcm_int [code] = dummy_Gcd_Lcm [where ?'a = int] 
lemmas dummy_Gcd_Lcm_nat [code] = dummy_Gcd_Lcm [where ?'a = nat] 

declare [[code abort: Euclidean_Algorithm.Gcd Euclidean_Algorithm.Lcm]]

end

Theory Berlekamp_Zassenhaus

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section ‹The Polynomial Factorization Algorithm›

subsection ‹Factoring Square-Free Integer Polynomials›

text ‹We combine all previous results, i.e., Berlekamp's algorithm, Hensel-lifting, the reconstruction
  of Zassenhaus, Mignotte-bounds, etc., to eventually assemble the factorization algorithm for 
  integer polynomials.›

theory Berlekamp_Zassenhaus
imports 
  Berlekamp_Hensel
  Polynomial_Factorization.Gauss_Lemma
  Polynomial_Factorization.Dvd_Int_Poly
  Reconstruction
  Suitable_Prime
  Degree_Bound
  Code_Abort_Gcd
begin

context
begin
private partial_function (tailrec) find_exponent_main :: "int  int  nat  int  nat" where
  [code]: "find_exponent_main p pm m bnd = (if pm > bnd then m
    else find_exponent_main p (pm * p) (Suc m) bnd)"

definition find_exponent :: "int  int  nat" where
  "find_exponent p bnd = find_exponent_main p p 1 bnd"
  
lemma find_exponent: assumes p: "p > 1" 
  shows "p ^ find_exponent p bnd > bnd" "find_exponent p bnd  0" 
proof -
  {
    fix m and n
    assume "n = nat (1 + bnd - p^m)" and "m  1" 
    hence "bnd < p ^ find_exponent_main p (p^m) m bnd  find_exponent_main p (p^m) m bnd  1" 
    proof (induct n arbitrary: m rule: less_induct)
      case (less n m)
      note simp = find_exponent_main.simps[of p "p^m"]
      show ?case
      proof (cases "bnd < p ^ m")
        case True
        thus ?thesis using less unfolding simp by simp
      next
        case False
        hence id: "find_exponent_main p (p ^ m) m bnd = find_exponent_main p (p ^ Suc m) (Suc m) bnd" 
          unfolding simp by (simp add: ac_simps)
        show ?thesis unfolding id 
          by (rule less(1)[OF _ refl], unfold less(2), insert False p, auto)
      qed
    qed
  }
  from this[OF refl, of 1]
  show "p ^ find_exponent p bnd > bnd" "find_exponent p bnd  0"
    unfolding find_exponent_def by auto
qed

end

definition berlekamp_zassenhaus_factorization :: "int poly  int poly list" where
  "berlekamp_zassenhaus_factorization f = (let 
     ― ‹find suitable prime›
     p = suitable_prime_bz f;
     ― ‹compute finite field factorization›
     (_, fs) = finite_field_factorization_int p f; 
     ― ‹determine maximal degree that we can build by multiplying at most half of the factors›
     max_deg = degree_bound fs;
     ― ‹determine a number large enough to represent all coefficients of every›
     ― ‹factor of lc * f› that has at most degree most max_deg›
     bnd = 2 * ¦lead_coeff f¦ * factor_bound f max_deg;
     ― ‹determine k› such that p^k > bnd›
     k = find_exponent p bnd;
     ― ‹perform hensel lifting to lift factorization to mod p^k›
     vs = hensel_lifting p k f fs
     ― ‹reconstruct integer factors›
   in zassenhaus_reconstruction vs p k f)" 
  
theorem berlekamp_zassenhaus_factorization_irreducibled:  
  assumes res: "berlekamp_zassenhaus_factorization f = fs" 
  and sf: "square_free f"
  and deg: "degree f > 0" 
  shows "f = prod_list fs  ( fi  set fs. irreducibled fi)" 
proof -
  let ?lc = "lead_coeff f" 
  define p where "p  suitable_prime_bz f" 
  obtain c gs where berl: "finite_field_factorization_int p f = (c,gs)" by force
  let ?degs = "map degree gs" 
  note res = res[unfolded berlekamp_zassenhaus_factorization_def Let_def, folded p_def,
    unfolded berl split, folded]
  from suitable_prime_bz[OF sf refl]
  have prime: "prime p" and cop: "coprime ?lc p" and sf: "poly_mod.square_free_m p f" 
    unfolding p_def by auto
  from prime interpret poly_mod_prime p by unfold_locales
  define n where "n = find_exponent p (2 * abs ?lc * factor_bound f (degree_bound gs))" 
  note n = find_exponent[OF m1, of "2 * abs ?lc * factor_bound f (degree_bound gs)",
    folded n_def]
  note bh = berlekamp_and_hensel_separated[OF cop sf refl berl n(2)]
  have db: "degree_bound (berlekamp_hensel p n f) = degree_bound gs" unfolding bh
    degree_bound_def max_factor_degree_def by simp
  note res = res[folded n_def bh(1)]
  show ?thesis 
    by (rule zassenhaus_reconstruction_irreducibled[OF prime cop sf deg refl _ res], insert n db, auto)
qed

corollary berlekamp_zassenhaus_factorization_irreducible:
  assumes res: "berlekamp_zassenhaus_factorization f = fs" 
    and sf: "square_free f"
    and pr: "primitive f"
    and deg: "degree f > 0"
  shows "f = prod_list fs  ( fi  set fs. irreducible fi)" 
  using pr irreducible_primitive_connect[OF primitive_prod_list]
    berlekamp_zassenhaus_factorization_irreducibled[OF res sf deg] by auto

end

Theory Gcd_Finite_Field_Impl

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹A fast coprimality approximation›

text ‹We adapt the integer polynomial gcd algorithm so that it 
  first tests whether $f$ and $g$ are coprime modulo a few primes.
  If so, we are immediately done.›

theory Gcd_Finite_Field_Impl
imports 
  Suitable_Prime
  Code_Abort_Gcd
  "HOL-Library.Code_Target_Int" (* to be able to efficiently primality of medium large numbers *)
begin

definition coprime_approx_main :: "int  'i arith_ops_record  int poly  int poly  bool" where
  "coprime_approx_main p ff_ops f g = (gcd_poly_i ff_ops (of_int_poly_i ff_ops (poly_mod.Mp p f))
     (of_int_poly_i ff_ops (poly_mod.Mp p g)) = one_poly_i ff_ops)" 

lemma (in prime_field_gen) coprime_approx_main: 
  shows "coprime_approx_main p ff_ops f g  coprime_m f g"
proof -
  define F where F: "(F :: 'a mod_ring poly) = of_int_poly (Mp f)"
  define G where G: "(G :: 'a mod_ring poly) = of_int_poly (Mp g)"  let ?f' = "of_int_poly_i ff_ops (Mp f)" 
  let ?g' = "of_int_poly_i ff_ops (Mp g)" 
  define f'' where "f''  of_int_poly (Mp f) :: 'a mod_ring poly"
  define g'' where "g''  of_int_poly (Mp g) :: 'a mod_ring poly"
  have rel_f[transfer_rule]: "poly_rel ?f' f''" 
    by (rule poly_rel_of_int_poly[OF refl], simp add: f''_def)
  have rel_f[transfer_rule]: "poly_rel ?g' g''" 
    by (rule poly_rel_of_int_poly[OF refl], simp add: g''_def)
  have id: "(gcd_poly_i ff_ops (of_int_poly_i ff_ops (Mp f)) (of_int_poly_i ff_ops (Mp g)) = one_poly_i ff_ops)
    = coprime f'' g''" (is "?P  ?Q")
  proof -
    have "?P  gcd f'' g'' = 1"
      unfolding separable_i_def by transfer_prover
    also have "  ?Q"
      by (simp add: coprime_iff_gcd_eq_1)
    finally show ?thesis .
  qed
  have fF: "MP_Rel (Mp f) F" unfolding F MP_Rel_def
    by (simp add: Mp_f_representative)
  have gG: "MP_Rel (Mp g) G" unfolding G MP_Rel_def
    by (simp add: Mp_f_representative)
  have "coprime f'' g'' = coprime F G" unfolding f''_def F g''_def G by simp
  also have " = coprime_m (Mp f) (Mp g)"
    using coprime_MP_Rel[unfolded rel_fun_def, rule_format, OF fF gG] by simp
  also have " = coprime_m f g" unfolding coprime_m_def dvdm_def by simp
  finally have id2: "coprime f'' g'' = coprime_m f g" .
  show "coprime_approx_main p ff_ops f g  coprime_m f g" unfolding coprime_approx_main_def
    id id2 by auto
qed

context poly_mod_prime begin

lemmas coprime_approx_main_uint32 = prime_field_gen.coprime_approx_main[OF 
        prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def
   poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas coprime_approx_main_uint64 = prime_field_gen.coprime_approx_main[OF 
        prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def
   poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

end

lemma coprime_mod_imp_coprime: assumes 
  p: "prime p" and 
  cop_m: "poly_mod.coprime_m p f g" and 
  cop: "coprime (lead_coeff f) p  coprime (lead_coeff g) p" and
  cnt: "content f = 1  content g = 1" 
  shows "coprime f g"
proof -
  interpret poly_mod_prime p by (standard, rule p)
  from cop_m[unfolded coprime_m_def] have cop_m: " h. h dvdm f  h dvdm g  h dvdm 1"  by auto
  show ?thesis 
  proof (rule coprimeI)
    fix h
    assume dvd: "h dvd f" "h dvd g" 
    hence "h dvdm f" "h dvdm g" unfolding dvdm_def dvd_def by auto
    from cop_m[OF this] obtain k where unit: "Mp (h * Mp k) = 1" unfolding dvdm_def by auto
    from content_dvd_contentI[OF dvd(1)] content_dvd_contentI[OF dvd(2)] cnt
    have cnt: "content h = 1" by auto 
    let ?k = "Mp k" 
    from unit have h0: "h  0" by auto
    from unit have k0: "?k  0" by fastforce
    from p have p0: "p  0" by auto
    from dvd have "lead_coeff h dvd lead_coeff f" "lead_coeff h dvd lead_coeff g" 
      by (metis dvd_def lead_coeff_mult)+
    with cop have coph: "coprime (lead_coeff h) p"
      by (meson dvd_trans not_coprime_iff_common_factor)
    let ?k = "Mp k"  
    from arg_cong[OF unit, of degree] have degm0: "degree_m (h * ?k) = 0" by simp
    have "lead_coeff ?k  {0 ..< p}" unfolding Mp_coeff M_def using m1 by simp
    with k0 have lk: "lead_coeff ?k  1" "lead_coeff ?k < p"
      by (auto simp add: int_one_le_iff_zero_less order.not_eq_order_implies_strict)
    have id: "lead_coeff (h * ?k) = lead_coeff h * lead_coeff ?k" unfolding lead_coeff_mult ..
    from coph prime lk have "coprime (lead_coeff h * lead_coeff ?k) p" 
      by (simp add: ac_simps prime_imp_coprime zdvd_not_zless)
    with id have cop_prod: "coprime (lead_coeff (h * ?k)) p" by simp
    from h0 k0 have lc0: "lead_coeff (h * ?k)  0"
      unfolding lead_coeff_mult by auto
    from p have lcp: "lead_coeff (h * ?k) mod p  0"
      using M_1 M_def cop_prod by auto
    have deg_eq: "degree_m (h * ?k) = degree (h * Mp k)" 
      by (rule degree_m_eq[OF _ m1], insert lcp)
    from this[unfolded degm0] have "degree (h * Mp k) = 0" by simp
    with degree_mult_eq[OF h0 k0] have deg0: "degree h = 0" by auto
    from degree0_coeffs[OF this] obtain h0 where h: "h = [:h0:]" by auto
    have "content h = abs h0" unfolding content_def h by (cases "h0 = 0", auto)
    hence "abs h0 = 1" using cnt by auto
    hence "h0  {-1,1}" by auto
    hence "h = 1  h = -1" unfolding h by (auto)
    thus "is_unit h" by auto
  qed
qed

text ‹We did not try to optimize the set of chosen primes. They have just been picked 
  randomly from a list of primes.›

definition gcd_primes32 :: "int list" where
  "gcd_primes32 = [383, 1409, 19213, 22003, 41999]" 
  
lemma gcd_primes32: "p  set gcd_primes32  prime p  p  65535" 
proof -
  have "list_all (λ p. prime p  p  65535) gcd_primes32" by eval
  thus "p  set gcd_primes32  prime p  p  65535" by (auto simp: list_all_iff)
qed

definition gcd_primes64 :: "int list" where
  "gcd_primes64 = [383, 21984191, 50329901, 80329901, 219849193]" 

lemma gcd_primes64: "p  set gcd_primes64  prime p  p  4294967295" 
proof -
  have "list_all (λ p. prime p  p  4294967295) gcd_primes64" by eval
  thus "p  set gcd_primes64  prime p  p  4294967295" by (auto simp: list_all_iff)
qed

definition coprime_heuristic :: "int poly  int poly  bool" where
  "coprime_heuristic f g = (let lcf = lead_coeff f; lcg = lead_coeff g in 
    find (λ p. (coprime lcf p  coprime lcg p)  coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g) 
    gcd_primes64  None)" 

lemma coprime_heuristic: assumes "coprime_heuristic f g" 
  and "content f = 1  content g = 1" 
  shows "coprime f g" 
proof (cases "find (λp. (coprime (lead_coeff f) p  coprime (lead_coeff g) p) 
            coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g)
   gcd_primes64")
  case (Some p)
  from find_Some_D[OF Some] gcd_primes64 have p: "prime p" and small: "p  4294967295" 
    and cop: "coprime (lead_coeff f) p  coprime (lead_coeff g) p" 
    and copp: "coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g" by auto
  interpret poly_mod_prime p using p by unfold_locales
  from coprime_approx_main_uint64[OF small copp] have "poly_mod.coprime_m p f g" by auto
  from coprime_mod_imp_coprime[OF p this cop assms(2)] show "coprime f g" .
qed (insert assms(1)[unfolded coprime_heuristic_def], auto simp: Let_def)

definition gcd_int_poly :: "int poly  int poly  int poly" where
  "gcd_int_poly f g =
    (if f = 0 then normalize g
     else if g = 0 then normalize f
          else let 
            cf = Polynomial.content f;
            cg = Polynomial.content g;
            ct = gcd cf cg;
            ff = map_poly (λ x. x div cf) f; 
            gg = map_poly (λ x. x div cg) g
          in if coprime_heuristic ff gg then [:ct:] else smult ct (gcd_poly_code_aux ff gg))" 

lemma gcd_int_poly_code[code_unfold]: "gcd = gcd_int_poly" 
proof (intro ext)
  fix f g :: "int poly"
  let ?ff = "primitive_part f" 
  let ?gg = "primitive_part g" 
  note d = gcd_int_poly_def gcd_poly_code gcd_poly_code_def
  show "gcd f g = gcd_int_poly f g" 
  proof (cases "f = 0  g = 0  ¬ coprime_heuristic ?ff ?gg")
    case True
    thus ?thesis unfolding d by (auto simp: Let_def primitive_part_def)
  next
    case False
    hence cop: "coprime_heuristic ?ff ?gg" by simp
    from False have "f  0" by auto
    from content_primitive_part[OF this] coprime_heuristic[OF cop]
    have id: "gcd ?ff ?gg = 1" by auto
    show ?thesis unfolding gcd_poly_decompose[of f g] unfolding gcd_int_poly_def Let_def id
      using False by (auto simp: primitive_part_def)
  qed
qed

end

Theory Square_Free_Factorization_Int

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
theory Square_Free_Factorization_Int
imports 
  Square_Free_Int_To_Square_Free_GFp 
  Suitable_Prime
  Code_Abort_Gcd
  Gcd_Finite_Field_Impl
begin

definition yun_wrel :: "int poly  rat  rat poly  bool" where
  "yun_wrel F c f = (map_poly rat_of_int F = smult c f)" 

definition yun_rel :: "int poly  rat  rat poly  bool" where
  "yun_rel F c f = (yun_wrel F c f
     content F = 1  lead_coeff F > 0  monic f)" 

definition yun_erel :: "int poly  rat poly  bool" where
  "yun_erel F f = ( c. yun_rel F c f)" 

lemma yun_wrelD: assumes "yun_wrel F c f"
  shows "map_poly rat_of_int F = smult c f" 
  using assms unfolding yun_wrel_def by auto

lemma yun_relD: assumes "yun_rel F c f"
  shows "yun_wrel F c f" "map_poly rat_of_int F = smult c f" 
    "degree F = degree f" "F  0" "lead_coeff F > 0" "monic f" 
    "f = 1  F = 1" "content F = 1" 
proof -
  note * = assms[unfolded yun_rel_def yun_wrel_def, simplified]
  then have "degree (map_poly rat_of_int F) = degree f" by auto
  then show deg: "degree F = degree f" by simp
  show "F  0" "lead_coeff F > 0" "monic f" "content F = 1" 
    "map_poly rat_of_int F = smult c f"
    "yun_wrel F c f" using * by (auto simp: yun_wrel_def)
  {
    assume "f = 1" 
    with deg have "degree F = 0" by auto
    from degree0_coeffs[OF this] obtain c where F: "F = [:c:]" and c: "c = lead_coeff F" by auto
    from c * have c0: "c > 0" by auto
    hence cF: "content F = c" unfolding F content_def by auto
    with * have "c = 1" by auto
    with F have "F = 1" by simp
  }
  moreover
  {
    assume "F = 1"
    with deg have "degree f = 0" by auto
    with ‹monic f have "f = 1" 
      using monic_degree_0 by blast
  }
  ultimately show "(f = 1)  (F = 1)" by auto
qed

lemma yun_erel_1_eq: assumes "yun_erel F f"
  shows "(F = 1)  (f = 1)" 
proof -
  from assms[unfolded yun_erel_def] obtain c where "yun_rel F c f" by auto
  from yun_relD[OF this] show ?thesis by simp
qed

lemma yun_rel_1[simp]: "yun_rel 1 1 1" 
  by (auto simp: yun_rel_def yun_wrel_def content_def)

lemma yun_erel_1[simp]: "yun_erel 1 1" unfolding yun_erel_def using yun_rel_1 by blast

lemma yun_rel_mult: "yun_rel F c f  yun_rel G d g  yun_rel (F * G) (c * d) (f * g)" 
  unfolding yun_rel_def yun_wrel_def content_mult lead_coeff_mult 
  by (auto simp: monic_mult hom_distribs)

lemma yun_erel_mult: "yun_erel F f  yun_erel G g  yun_erel (F * G) (f * g)" 
  unfolding yun_erel_def using yun_rel_mult[of F _ f G _ g] by blast

lemma yun_rel_pow: assumes "yun_rel F c f"
  shows "yun_rel (F^n) (c^n) (f^n)" 
  by (induct n, insert assms yun_rel_mult, auto)

lemma yun_erel_pow: "yun_erel F f  yun_erel (F^n) (f^n)" 
  using yun_rel_pow unfolding yun_erel_def by blast

lemma yun_wrel_pderiv: assumes "yun_wrel F c f"
  shows "yun_wrel (pderiv F) c (pderiv f)" 
  by (unfold yun_wrel_def, simp add: yun_wrelD[OF assms] pderiv_smult hom_distribs)

lemma yun_wrel_minus: assumes "yun_wrel F c f" "yun_wrel G c g" 
  shows "yun_wrel (F - G) c (f - g)" 
  using assms unfolding yun_wrel_def by (auto simp: smult_diff_right hom_distribs)

lemma yun_wrel_div: assumes f: "yun_wrel F c f" and g: "yun_wrel G d g" 
  and dvd: "G dvd F" "g dvd f" 
  and G0: "G  0" 
  shows "yun_wrel (F div G) (c / d) (f div g)" 
proof -
  let ?r = "rat_of_int" 
  let ?rp = "map_poly ?r" 
  from dvd obtain H h where fgh: "F = G * H" "f = g * h" unfolding dvd_def by auto
  from G0 yun_wrelD[OF g] have g0: "g  0" and d0: "d  0" by auto
  from arg_cong[OF fgh(1), of "λ x. x div G"] have H: "H = F div G" using G0 by simp
  from arg_cong[OF fgh(1), of ?rp] have "?rp F = ?rp G * ?rp H" by (auto simp: hom_distribs)
  from arg_cong[OF this, of "λ x. x div ?rp G"] G0 have id: "?rp H = ?rp F div ?rp G" by auto
  have "?rp (F div G) = ?rp F div ?rp G" unfolding H[symmetric] id by simp
  also have " = smult c f div smult d g" using f g unfolding yun_wrel_def by auto
  also have " = smult (c / d) (f div g)" unfolding div_smult_right[OF d0] div_smult_left
    by (simp add: field_simps)
  finally show ?thesis unfolding yun_wrel_def by simp
qed

lemma yun_rel_div: assumes f: "yun_rel F c f" and g: "yun_rel G d g" 
  and dvd: "G dvd F" "g dvd f" 
shows "yun_rel (F div G) (c / d) (f div g)" 
proof -
  note ff = yun_relD[OF f] 
  note gg = yun_relD[OF g]
  show ?thesis unfolding yun_rel_def
  proof (intro conjI)
    from yun_wrel_div[OF ff(1) gg(1) dvd gg(4)]
    show "yun_wrel (F div G) (c / d) (f div g)" by auto
    from dvd have fg: "f = g * (f div g)" by auto
    from arg_cong[OF fg, of monic] ff(6) gg(6) 
    show "monic (f div g)" using monic_factor by blast
    from dvd have FG: "F = G * (F div G)" by auto
    from arg_cong[OF FG, of content, unfolded content_mult] ff(8) gg(8)
    show "content (F div G) = 1" by simp
    from arg_cong[OF FG, of lead_coeff, unfolded lead_coeff_mult] ff(5) gg(5)
    show "lead_coeff (F div G) > 0" by (simp add: zero_less_mult_iff)
  qed
qed 
  


lemma yun_wrel_gcd: assumes "yun_wrel F c' f" "yun_wrel G c g" and c: "c'  0" "c  0" 
  and d: "d = rat_of_int (lead_coeff (gcd F G))" "d  0" 
  shows "yun_wrel (gcd F G) d (gcd f g)" 
proof -
  let ?r = "rat_of_int" 
  let ?rp = "map_poly ?r" 
  have "smult d (gcd f g) = smult d (gcd (smult c' f) (smult c g))" 
    by (simp add: c gcd_smult_left gcd_smult_right)
  also have " = smult d (gcd (?rp F) (?rp G))" using assms(1-2)[unfolded yun_wrel_def] by simp
  also have " = smult (d * inverse d) (?rp (gcd F G))" 
    unfolding gcd_rat_to_gcd_int d by simp
  also have "d * inverse d = 1" using d by auto
  finally show ?thesis  unfolding yun_wrel_def by simp
qed

lemma yun_rel_gcd: assumes f: "yun_rel F c f" and g: "yun_wrel G c' g"  and c': "c'  0" 
  and d: "d = rat_of_int (lead_coeff (gcd F G))"  
shows "yun_rel (gcd F G) d (gcd f g)" 
  unfolding yun_rel_def
proof (intro conjI)
  note ff = yun_relD[OF f]
  from ff have c0: "c  0" by auto
  from ff d have d0: "d  0" by auto
  from yun_wrel_gcd[OF ff(1) g c0 c' d d0]
  show "yun_wrel (gcd F G) d (gcd f g)" by auto
  from ff have "gcd f g  0" by auto
  thus "monic (gcd f g)" by (simp add: poly_gcd_monic)
  obtain H where H: "gcd F G = H" by auto
  obtain lc where lc: "coeff H (degree H) = lc" by auto
  from ff have "gcd F G  0" by auto
  hence "H  0" "lc  0" unfolding H[symmetric] lc[symmetric] by auto
  thus "0 < lead_coeff (gcd F G)" unfolding 
    arg_cong[OF normalize_gcd[of F G], of lead_coeff, symmetric]
    unfolding normalize_poly_eq_map_poly H
    by (auto, subst Polynomial.coeff_map_poly, auto, 
    subst Polynomial.degree_map_poly, auto simp: sgn_if)
  have "H dvd F" unfolding H[symmetric] by auto
  then obtain K where F: "F = H * K" unfolding dvd_def by auto
  from arg_cong[OF this, of content, unfolded content_mult ff(8)]
    content_ge_0_int[of H] have "content H = 1"
    by (auto simp add: zmult_eq_1_iff)
  thus "content (gcd F G) = 1" unfolding H .
qed
  


lemma yun_factorization_main_int: assumes f: "f = p div gcd p (pderiv p)"
    and "g = pderiv p div gcd p (pderiv p)" "monic p" 
    and "yun_gcd.yun_factorization_main gcd f g i hs = res"
    and "yun_gcd.yun_factorization_main gcd F G i Hs = Res" 
    and "yun_rel F c f" "yun_wrel G c g" "list_all2 (rel_prod yun_erel (=)) Hs hs"
  shows "list_all2 (rel_prod yun_erel (=)) Res res" 
proof -
  let ?P = "λ f g.  i hs res F G Hs Res c. 
    yun_gcd.yun_factorization_main gcd f g i hs = res
     yun_gcd.yun_factorization_main gcd F G i Hs = Res 
     yun_rel F c f  yun_wrel G c g  list_all2 (rel_prod yun_erel (=)) Hs hs
     list_all2 (rel_prod yun_erel (=)) Res res" 
  note simps = yun_gcd.yun_factorization_main.simps
  note rel = yun_relD
  let ?rel = "λ F f. map_poly rat_of_int F = smult (rat_of_int (lead_coeff F)) f" 
  show ?thesis
  proof (induct rule: yun_factorization_induct[of ?P, rule_format, OF _ _ assms])
    case (1 f g i hs res F G Hs Res c)
    from rel[OF 1(4)] 1(1) have "f = 1" "F = 1" by auto
    from 1(2-3)[unfolded simps[of _ 1] this] have "res = hs" "Res = Hs" by auto
    with 1(6) show ?case by simp
  next
    case (2 f g i hs res F G Hs Res c)
    define d where "d = g - pderiv f" 
    define a where "a = gcd f d"  
    define D where "D = G - pderiv F" 
    define A where "A = gcd F D"  
    note f = 2(5)
    note g = 2(6)
    note hs = 2(7)
    note f1 = 2(1)
    from f1 rel[OF f] have *: "(f = 1) = False" "(F = 1) = False" and c: "c  0" by auto
    note res = 2(3)[unfolded simps[of _ f] * if_False Let_def, folded d_def a_def]
    note Res = 2(4)[unfolded simps[of _ F] * if_False Let_def, folded D_def A_def]
    note IH = 2(2)[folded d_def a_def, OF res Res]
    obtain c' where c': "c' = rat_of_int (lead_coeff (gcd F D))" by auto
    show ?case
    proof (rule IH)
      from yun_wrel_minus[OF g yun_wrel_pderiv[OF rel(1)[OF f]]]
      have d: "yun_wrel D c d" unfolding D_def d_def .
      have a: "yun_rel A c' a" unfolding A_def a_def
        by (rule yun_rel_gcd[OF f d c c'])
      hence "yun_erel A a" unfolding yun_erel_def by auto
      thus "list_all2 (rel_prod yun_erel (=)) ((A, i) # Hs) ((a, i) # hs)" 
        using hs by auto      
      have A0: "A  0" by (rule rel(4)[OF a])
      have "A dvd D" "a dvd d" unfolding A_def a_def by auto
      from yun_wrel_div[OF d rel(1)[OF a] this A0]
      show "yun_wrel (D div A) (c / c') (d div a)" .
      have "A dvd F" "a dvd f" unfolding A_def a_def by auto
      from yun_rel_div[OF f a this]
      show "yun_rel (F div A) (c / c') (f div a)" .
    qed
  qed
qed

lemma yun_monic_factorization_int_yun_rel: assumes  
    res: "yun_gcd.yun_monic_factorization gcd f = res"
    and Res: "yun_gcd.yun_monic_factorization gcd F = Res" 
    and f: "yun_rel F c f" 
  shows "list_all2 (rel_prod yun_erel (=)) Res res" 
proof -
  note ff = yun_relD[OF f]
  let ?g = "gcd f (pderiv f)"
  let ?yf = "yun_gcd.yun_factorization_main gcd (f div ?g) (pderiv f div ?g) 0 []" 
  let ?G = "gcd F (pderiv F)"
  let ?yF = "yun_gcd.yun_factorization_main gcd (F div ?G) (pderiv F div ?G) 0 []" 
  obtain r R where r: "?yf = r" and R: "?yF = R" by blast  
  from res[unfolded yun_gcd.yun_monic_factorization_def Let_def r]
  have res: "res = [(a, i)r . a  1]" by simp
  from Res[unfolded yun_gcd.yun_monic_factorization_def Let_def R]
  have Res: "Res = [(A, i)R . A  1]" by simp
  from yun_wrel_pderiv[OF ff(1)] have f': "yun_wrel (pderiv F) c (pderiv f)" .
  from ff have c: "c  0" by auto
  from yun_rel_gcd[OF f f' c refl] obtain d where g: "yun_rel ?G d ?g" ..
  from yun_rel_div[OF f g] have 1: "yun_rel (F div ?G) (c / d) (f div ?g)" by auto
  from yun_wrel_div[OF f' yun_relD(1)[OF g] _ _ yun_relD(4)[OF g]] 
  have 2: "yun_wrel (pderiv F div ?G) (c / d) (pderiv f div ?g)" by auto
  from yun_factorization_main_int[OF refl refl ff(6) r R 1 2] 
  have "list_all2 (rel_prod yun_erel (=)) R r" by simp
  thus ?thesis unfolding res Res
    by (induct R r rule: list_all2_induct, auto dest: yun_erel_1_eq)
qed

lemma yun_rel_same_right: assumes "yun_rel f c G" "yun_rel g d G" 
  shows "f = g" 
proof -
  note f = yun_relD[OF assms(1)]
  note g = yun_relD[OF assms(2)]
  let ?r = "rat_of_int" 
  let ?rp = "map_poly ?r" 
  from g have d: "d  0" by auto
  obtain a b where quot: "quotient_of (c / d) = (a,b)" by force
  from quotient_of_nonzero[of "c/d", unfolded quot] have b: "b  0" by simp
  note f(2)
  also have "smult c G = smult (c / d) (smult d G)" using d by (auto simp: field_simps)
  also have "smult d G = ?rp g" using g(2) by simp
  also have cd: "c / d = (?r a / ?r b)" using quotient_of_div[OF quot] .
  finally have fg: "?rp f = smult (?r a / ?r b) (?rp g)" by simp
  from f have "c  0" by auto
  with cd d have a: "a  0" by auto
  from arg_cong[OF fg, of "λ x. smult (?r b) x"]
  have "smult (?r b) (?rp f) = smult (?r a) (?rp g)" using b by auto
  hence "?rp (smult b f) = ?rp (smult a g)" by (auto simp: hom_distribs)
  then have fg: "[:b:] * f = [:a:] * g" by auto
  from arg_cong[OF this, of content, unfolded content_mult f(8) g(8)] 
  have "content [: b :] = content [: a :]" by simp
  hence abs: "abs a = abs b" unfolding content_def using b a by auto
  from arg_cong[OF fg, of "λ x. lead_coeff x > 0", unfolded lead_coeff_mult] f(5) g(5) a b 
  have "(a > 0) = (b > 0)" by (simp add: zero_less_mult_iff)
  with a b abs have "a = b" by auto
  with arg_cong[OF fg, of "λ x. x div [:b:]"] b show ?thesis
    by (metis nonzero_mult_div_cancel_left pCons_eq_0_iff)
qed



definition square_free_factorization_int_main :: "int poly  (int poly × nat) list" where 
  "square_free_factorization_int_main f = (case square_free_heuristic f of None  
    yun_gcd.yun_monic_factorization gcd f | Some p  [(f,0)])"

lemma square_free_factorization_int_main: assumes res: "square_free_factorization_int_main f = fs"
  and ct: "content f = 1" and lc: "lead_coeff f > 0" 
  and deg: "degree f  0" 
shows "square_free_factorization f (1,fs)  ( fi i. (fi, i)  set fs  content fi = 1  lead_coeff fi > 0) 
  distinct (map snd fs)" 
proof (cases "square_free_heuristic f")
  case None  
  from lc have f0: "f  0" by auto
  from res None have fs: "yun_gcd.yun_monic_factorization gcd f = fs" 
    unfolding square_free_factorization_int_main_def by auto
  let ?r = "rat_of_int" 
  let ?rp = "map_poly ?r" 
  define G where "G = smult (inverse (lead_coeff (?rp f))) (?rp f)" 
  have "?rp f  0" using f0 by auto
  hence mon: "monic G" unfolding G_def coeff_smult by simp    
  obtain Fs where Fs: "yun_gcd.yun_monic_factorization gcd G = Fs" by blast
  from lc have lg: "lead_coeff (?rp f)  0" by auto
  let ?c = "lead_coeff (?rp f)" 
  define c where "c = ?c"
  have rp: "?rp f = smult c G" unfolding G_def c_def by (simp add: field_simps)
  have in_rel: "yun_rel f c G" unfolding yun_rel_def yun_wrel_def
    using rp mon lc ct by auto
  from yun_monic_factorization_int_yun_rel[OF Fs fs in_rel]
  have out_rel: "list_all2 (rel_prod yun_erel (=)) fs Fs" by auto
  from yun_monic_factorization[OF Fs mon]
  have "square_free_factorization G (1, Fs)" and dist: "distinct (map snd Fs)" by auto
  note sff = square_free_factorizationD[OF this(1)]
  from out_rel have "map snd fs = map snd Fs" by (induct fs Fs rule: list_all2_induct, auto)
  with dist have dist': "distinct (map snd fs)" by auto
  have main: "square_free_factorization f (1, fs)  ( fi i. (fi, i)  set fs  content fi = 1  lead_coeff fi > 0)"
    unfolding square_free_factorization_def split
  proof (intro conjI allI impI)
    from ct have "f  0" by auto
    thus "f = 0  1 = 0" "f = 0  fs = []" by auto
    from dist' show "distinct fs" by (simp add: distinct_map)
    {
      fix a i
      assume a: "(a,i)  set fs" 
      with out_rel obtain bj where "bj  set Fs" and "rel_prod yun_erel (=) (a,i) bj" 
        unfolding list_all2_conv_all_nth set_conv_nth by fastforce
      then obtain b where b: "(b,i)  set Fs" and ab: "yun_erel a b" by (cases bj, auto simp: rel_prod.simps)
      from sff(2)[OF b] have b': "square_free b" "degree b  0" by auto
      from ab obtain c where rel: "yun_rel a c b" unfolding yun_erel_def by auto
      note aa = yun_relD[OF this]
      from aa have c0: "c  0" by auto
      from b' aa(3) show "degree a > 0" by simp
      from square_free_smult[OF c0 b'(1), folded aa(2)]
      show "square_free a" unfolding square_free_def by (force simp: dvd_def hom_distribs)
      show cnt: "content a = 1" and lc: "lead_coeff a > 0" using aa by auto
      fix A I
      assume A: "(A,I)  set fs" and diff: "(a,i)  (A,I)" 
      from a[unfolded set_conv_nth] obtain k where k: "fs ! k = (a,i)" "k < length fs" by auto
      from A[unfolded set_conv_nth] obtain K where K: "fs ! K = (A,I)" "K < length fs" by auto
      from diff k K have kK: "k  K" by auto
      from dist'[unfolded distinct_conv_nth length_map, rule_format, OF k(2) K(2) kK] 
      have iI: "i  I" using k K by simp
      from A out_rel obtain Bj where "Bj  set Fs" and "rel_prod yun_erel (=) (A,I) Bj" 
        unfolding list_all2_conv_all_nth set_conv_nth by fastforce
      then obtain B where B: "(B,I)  set Fs" and AB: "yun_erel A B" by (cases Bj, auto simp: rel_prod.simps)
      then obtain C where Rel: "yun_rel A C B" unfolding yun_erel_def by auto
      note AA = yun_relD[OF this]
      from iI have "(b,i)  (B,I)" by auto
      from sff(3)[OF b B this] have cop: "coprime b B" by simp
      from AA have C: "C  0" by auto
      from yun_rel_gcd[OF rel AA(1) C refl] obtain c where "yun_rel (gcd a A) c (gcd b B)" by auto
      note rel = yun_relD[OF this]
      from rel(2) cop have "?rp (gcd a A) = [: c :]" by simp
      from arg_cong[OF this, of degree] have "degree (gcd a A) = 0" by simp
      from degree0_coeffs[OF this] obtain c where gcd: "gcd a A = [: c :]" by auto
      from rel(8) rel(5) show "Rings.coprime a A"
        by (auto intro!: gcd_eq_1_imp_coprime simp add: gcd)
    }
    let ?prod = "λ fs. ((a, i)set fs. a ^ Suc i)" 
    let ?pr = "λ fs. ((a, i)fs. a ^ Suc i)"
    define pr where "pr = ?prod fs" 
    from ‹distinct fs have pfs: "?prod fs = ?pr fs" by (rule prod.distinct_set_conv_list)
    from ‹distinct Fs have pFs: "?prod Fs = ?pr Fs" by (rule prod.distinct_set_conv_list)
    from out_rel have "yun_erel (?prod fs) (?prod Fs)" unfolding pfs pFs
    proof (induct fs Fs rule: list_all2_induct)
      case (Cons ai fs Ai Fs)
      obtain a i where ai: "ai = (a,i)" by force
      from Cons(1) ai obtain A where Ai: "Ai = (A,i)" 
        and rel: "yun_erel a A" by (cases Ai, auto simp: rel_prod.simps)
      show ?case unfolding ai Ai using yun_erel_mult[OF yun_erel_pow[OF rel, of "Suc i"] Cons(3)]
        by auto
    qed simp
    also have "?prod Fs = G" using sff(1) by simp
    finally obtain d where rel: "yun_rel pr d G" unfolding yun_erel_def pr_def by auto
    with in_rel have "f = pr" by (rule yun_rel_same_right)
    thus "f = smult 1 (?prod fs)" unfolding pr_def by simp
  qed
  from main dist' show ?thesis by auto
next
  case (Some p)
  from res[unfolded square_free_factorization_int_main_def Some] have fs: "fs = [(f,0)]" by auto
  from lc have f0: "f  0" by auto
  from square_free_heuristic[OF Some] poly_mod_prime.separable_impl(1)[of p f] square_free_mod_imp_square_free[of p f] deg
  show ?thesis unfolding fs
    by (auto simp: ct lc square_free_factorization_def f0 poly_mod_prime_def)
qed

definition square_free_factorization_int' :: "int poly  int × (int poly × nat)list" where
  "square_free_factorization_int' f = (if degree f = 0
    then (lead_coeff f,[]) else (let ― ‹content factorization›
      c = content f;
      d = (sgn (lead_coeff f) * c);
      g = sdiv_poly f d
      ― ‹and square_free› factorization›
    in (d, square_free_factorization_int_main g)))"


lemma square_free_factorization_int': assumes res: "square_free_factorization_int' f = (d, fs)"
  shows "square_free_factorization f (d,fs)" 
    "(fi, i)  set fs  content fi = 1  lead_coeff fi > 0" 
    "distinct (map snd fs)" 
proof -
  note res = res[unfolded square_free_factorization_int'_def Let_def]
  have "square_free_factorization f (d,fs) 
     ((fi, i)  set fs  content fi = 1  lead_coeff fi > 0)
     distinct (map snd fs)"
  proof (cases "degree f = 0")
    case True
    from degree0_coeffs[OF True] obtain c where f: "f = [: c :]" by auto
    thus ?thesis using res by (simp add: square_free_factorization_def)
  next
    case False
    let ?s = "sgn (lead_coeff f)" 
    have s: "?s  {-1,1}" using False unfolding sgn_if by auto
    define g where "g = smult ?s f" 
    let ?d = "?s * content f"
    have "content g = content ([:?s:] * f)" unfolding g_def by simp
    also have " = content [:?s:] * content f" unfolding content_mult by simp
    also have "content [:?s:] = 1" using s by (auto simp: content_def)
    finally have cg: "content g = content f" by simp
    from False res 
    have d: "d = ?d" and fs: "fs = square_free_factorization_int_main (sdiv_poly f ?d)" by auto
    let ?g = "primitive_part g" 
    define ng where "ng = primitive_part g" 
    note fs
    also have "sdiv_poly f ?d = sdiv_poly g (content g)" unfolding cg unfolding g_def
      by (rule poly_eqI, unfold coeff_sdiv_poly coeff_smult, insert s, auto simp: div_minus_right)
    finally have fs: "square_free_factorization_int_main ng = fs" 
      unfolding primitive_part_alt_def ng_def by simp
    have "lead_coeff f  0" using False by auto
    hence lg: "lead_coeff g > 0" unfolding g_def lead_coeff_smult
      by (meson linorder_neqE_linordered_idom sgn_greater sgn_less zero_less_mult_iff)
    hence g0: "g  0" by auto
    from g0 have "content g  0" by simp
    from arg_cong[OF content_times_primitive_part[of g], of lead_coeff, unfolded lead_coeff_smult]
      lg content_ge_0_int[of g] have lg': "lead_coeff ng > 0" unfolding ng_def 
      by (metis ‹content g  0 dual_order.antisym dual_order.strict_implies_order zero_less_mult_iff)
    from content_primitive_part[OF g0] have c_ng: "content ng = 1" unfolding ng_def .
    have "degree ng = degree f" using ‹content [:sgn (lead_coeff f):] = 1 g_def ng_def
      by (auto simp add: sgn_eq_0_iff)
    with False have "degree ng  0" by auto
    note main = square_free_factorization_int_main[OF fs c_ng lg' this] 
    show ?thesis
    proof (intro conjI impI)
      {
        assume "(fi, i)  set fs" 
        with main show "content fi = 1" "0 < lead_coeff fi" by auto
      }
      have d0: "d  0" using ‹content [:?s:] = 1 d by (auto simp:sgn_eq_0_iff)
      have "smult d ng = smult ?s (smult (content g) (primitive_part g))" 
        unfolding ng_def d cg by simp
      also have "smult (content g) (primitive_part g) = g" using content_times_primitive_part .
      also have "smult ?s g = f" unfolding g_def using s by auto
      finally have id: "smult d ng = f" .
      from main have "square_free_factorization ng (1, fs)" by auto
      from square_free_factorization_smult[OF d0 this]
      show "square_free_factorization f (d,fs)" unfolding id by simp
      show "distinct (map snd fs)" using main by auto
    qed
  qed
  thus  "square_free_factorization f (d,fs)" 
    "(fi, i)  set fs  content fi = 1  lead_coeff fi > 0" "distinct (map snd fs)" by auto
qed

 
definition x_split :: "'a :: semiring_0 poly  nat × 'a poly" where
  "x_split f = (let fs = coeffs f; zs = takeWhile ((=) 0) fs
     in case zs of []  (0,f) | _  (length zs, poly_of_list (dropWhile ((=) 0) fs)))" 
  
lemma x_split: assumes "x_split f = (n, g)" 
  shows "f = monom 1 n * g" "n  0  f  0  ¬ monom 1 1 dvd g"
proof -
  define zs where "zs = takeWhile ((=) 0) (coeffs f)" 
  note res = assms[unfolded zs_def[symmetric] x_split_def Let_def]
  have "f = monom 1 n * g  ((n  0  f  0)  ¬ (monom 1 1 dvd g))" (is "_  (_  ¬ (?x dvd _))")
  proof (cases "f = 0")
    case True
    with res have "n = 0" "g = 0" unfolding zs_def by auto
    thus ?thesis using True by auto
  next
    case False note f = this
    show ?thesis
    proof (cases "zs = []")
      case True
      hence choice: "coeff f 0  0" using f unfolding zs_def coeff_f_0_code poly_compare_0_code
        by (cases "coeffs f", auto)
      have dvd: "?x dvd h  coeff h 0 = 0" for h by (simp add: monom_1_dvd_iff')
      from True choice res f show ?thesis unfolding dvd by auto
    next
      case False
      define ys where "ys = dropWhile ((=) 0) (coeffs f)" 
      have dvd: "?x dvd h  coeff h 0 = 0" for h by (simp add: monom_1_dvd_iff')
      from res False have n: "n = length zs" and g: "g = poly_of_list ys" unfolding ys_def
        by (cases zs, auto)+
      obtain xx where xx: "coeffs f = xx" by auto
      have "coeffs f = zs @ ys" unfolding zs_def ys_def by auto
      also have "zs = replicate n 0" unfolding zs_def n xx by (induct xx, auto)
      finally have ff: "coeffs f = replicate n 0 @ ys" by auto
      from f have "lead_coeff f  0" by auto
      then have nz: "coeffs f  []" "last (coeffs f)  0"
        by (simp_all add: last_coeffs_eq_coeff_degree)
      have ys: "ys  []" using nz[unfolded ff] by auto            
      with ys_def have hd: "hd ys  0" by (metis (full_types) hd_dropWhile)
      hence "coeff (poly_of_list ys) 0  0" unfolding poly_of_list_def coeff_Poly using ys by (cases ys, auto)
      moreover have "coeffs (Poly ys) = ys"
        by (simp add: ys_def strip_while_dropWhile_commute)
      then have "coeffs (monom_mult n (Poly ys)) = replicate n 0 @ ys"
        by (simp add: coeffs_eq_iff monom_mult_def [symmetric] ff ys monom_mult_code)
      ultimately show ?thesis unfolding dvd g
        by (auto simp add: coeffs_eq_iff monom_mult_def [symmetric] ff)
    qed
  qed
  thus "f = monom 1 n * g" "n  0  f  0  ¬ monom 1 1 dvd g" by auto
qed
      

definition square_free_factorization_int :: "int poly  int × (int poly × nat)list" where
  "square_free_factorization_int f = (case x_split f of (n,g) ― ‹extract x^n›
     case square_free_factorization_int' g of (d,fs)
     if n = 0 then (d,fs) else (d, (monom 1 1, n - 1) # fs))" 

lemma square_free_factorization_int: assumes res: "square_free_factorization_int f = (d, fs)"
  shows "square_free_factorization f (d,fs)" 
    "(fi, i)  set fs  primitive fi  lead_coeff fi > 0" 
proof -
  obtain n g where xs: "x_split f = (n,g)" by force
  obtain c hs where sf: "square_free_factorization_int' g = (c,hs)" by force
  from res[unfolded square_free_factorization_int_def xs sf split] 
  have d: "d = c" and fs: "fs = (if n = 0 then hs else (monom 1 1, n - 1) # hs)" by (cases n, auto)
  note sff = square_free_factorization_int'(1-2)[OF sf]
  note xs = x_split[OF xs]
  let ?x = "monom 1 1 :: int poly" 
  have x: "primitive ?x  lead_coeff ?x = 1  degree ?x = 1"
    by (auto simp add: degree_monom_eq content_def monom_Suc)
  thus "(fi, i)  set fs  primitive fi  lead_coeff fi > 0" using sff(2) unfolding fs
    by (cases n, auto)
  show "square_free_factorization f (d,fs)" 
  proof (cases n)
    case 0
    with d fs sff xs show ?thesis by auto
  next
    case (Suc m)
    with xs have fg: "f = monom 1 (Suc m) * g" and dvd: "¬ ?x dvd g" by auto
    from Suc have fs: "fs = (?x,m) # hs" unfolding fs by auto
    have degx: "degree ?x = 1" by code_simp 
    from irreducibled_square_free[OF linear_irreducibled[OF this]] have sfx: "square_free ?x" by auto
    have fg: "f = ?x ^ n * g" unfolding fg Suc by (metis x_pow_n)
    have eq0: "?x ^ n * g = 0  g = 0" by simp
    note sf = square_free_factorizationD[OF sff(1)]
    {
      fix a i
      assume ai: "(a,i)  set hs" 
      with sf(4) have g0: "g  0" by auto
      from split_list[OF ai] obtain ys zs where hs: "hs = ys @ (a,i) # zs" by auto
      have "a dvd g" unfolding square_free_factorization_prod_list[OF sff(1)] hs
        by (rule dvd_smult, simp add: ac_simps)
      moreover have "¬ ?x dvd g" using xs[unfolded Suc] by auto
      ultimately have dvd: "¬ ?x dvd a" using dvd_trans by blast
      from sf(2)[OF ai] have "a  0" by auto
      have "1 = gcd ?x a"
      proof (rule gcdI)
        fix d
        assume d: "d dvd ?x" "d dvd a" 
        from content_dvd_contentI[OF d(1)] x have cnt: "is_unit (content d)" by auto
        show "is_unit d"
        proof (cases "degree d = 1")
          case False
          with divides_degree[OF d(1), unfolded degx] have "degree d = 0" by auto
          from degree0_coeffs[OF this] obtain c where dc: "d = [:c:]" by auto
          from cnt[unfolded dc] have "is_unit c" by (auto simp: content_def, cases "c = 0", auto)
          hence "d * d = 1" unfolding dc by (cases "c = -1"; cases "c = 1", auto)
          thus "is_unit d" by (metis dvd_triv_right)
        next
          case True
          from d(1) obtain e where xde: "?x = d * e" unfolding dvd_def by auto
          from arg_cong[OF this, of degree] degx have "degree d + degree e = 1"
            by (metis True add.right_neutral degree_0 degree_mult_eq one_neq_zero)
          with True have "degree e = 0" by auto
          from degree0_coeffs[OF this] xde obtain e where xde: "?x = [:e:] * d" by auto
          from arg_cong[OF this, of content, unfolded content_mult] x
          have "content [:e:] * content d = 1" by auto
          also have "content [:e :] = abs e" by (auto simp: content_def, cases "e = 0", auto)
          finally have "¦e¦ * content d = 1" .
          from pos_zmult_eq_1_iff_lemma[OF this] have "e * e = 1" by (cases "e = 1"; cases "e = -1", auto)
          with arg_cong[OF xde, of "smult e"] have "d = ?x * [:e:]" by auto
          hence "?x dvd d" unfolding dvd_def by blast
          with d(2) have "?x dvd a" by (metis dvd_trans)
          with dvd show ?thesis by auto
        qed
      qed auto
      hence "coprime ?x a"
        by (simp add: gcd_eq_1_imp_coprime)
      note this dvd
    } note hs_dvd_x = this
    from hs_dvd_x[of ?x m]
    have nmem: "(?x,m)  set hs" by auto
    hence eq: "?x ^ n * g = smult c ((a, i)set fs. a ^ Suc i)" 
      unfolding sf(1) unfolding fs Suc by simp
    show ?thesis unfolding fg d unfolding square_free_factorization_def split eq0 unfolding eq
    proof (intro conjI allI impI, rule refl)
      fix a i 
      assume ai: "(a,i)  set fs" 
      thus "square_free a" "degree a > 0" using sf(2) sfx degx unfolding fs by auto
      fix b j
      assume bj: "(b,j)  set fs" and diff: "(a,i)  (b,j)" 
      consider (hs_hs) "(a,i)  set hs" "(b,j)  set hs" 
        | (hs_x) "(a,i)  set hs" "b = ?x" 
        | (x_hs) "(b,j)  set hs" "a = ?x" 
        using ai bj diff unfolding fs by auto
      then show "Rings.coprime a b"
      proof cases
        case hs_hs
        from sf(3)[OF this diff] show ?thesis .
      next
        case hs_x
        from hs_dvd_x(1)[OF hs_x(1)] show ?thesis unfolding hs_x(2) by (simp add: ac_simps)
      next
        case x_hs
        from hs_dvd_x(1)[OF x_hs(1)] show ?thesis unfolding x_hs(2) by simp
      qed
    next
      show "g = 0  c = 0" using sf(4) by auto
      show "g = 0  fs = []" using sf(4) xs Suc by auto
      show "distinct fs" using sf(5) nmem unfolding fs by auto
    qed
  qed
qed

end

Theory Factorize_Int_Poly

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Factoring Arbitrary Integer Polynomials›

text ‹We combine the factorization algorithm for square-free integer polynomials
  with a square-free factorization algorithm to
  a factorization algorithm for integer polynomials which does not make
  any assumptions.›
theory Factorize_Int_Poly
imports
  Berlekamp_Zassenhaus
  Square_Free_Factorization_Int
begin

hide_const coeff monom
lifting_forget poly.lifting

typedef int_poly_factorization_algorithm = "{alg. 
   (f :: int poly) fs. square_free f  degree f > 0  alg f = fs  
  (f = prod_list fs  ( fi  set fs. irreducibled fi))}" 
  by (rule exI[of _ berlekamp_zassenhaus_factorization], 
      insert berlekamp_zassenhaus_factorization_irreducibled, auto)

setup_lifting type_definition_int_poly_factorization_algorithm

lift_definition int_poly_factorization_algorithm :: "int_poly_factorization_algorithm 
  (int poly  int poly list)" is "λ x. x" .

lemma int_poly_factorization_algorithm_irreducibled: 
  assumes "int_poly_factorization_algorithm alg f = fs" 
  and "square_free f"
  and "degree f > 0" 
shows "f = prod_list fs  ( fi  set fs. irreducibled fi)" 
  using assms by (transfer, auto)

corollary int_poly_factorization_algorithm_irreducible:
  assumes res: "int_poly_factorization_algorithm alg f = fs" 
  and sf: "square_free f"
  and deg: "degree f > 0"
  and pr: "primitive f"
  shows "f = prod_list fs  ( fi  set fs. irreducible fi  degree fi > 0  primitive fi)" 
proof (intro conjI ballI)
  note * = int_poly_factorization_algorithm_irreducibled[OF res sf deg]
  from * show f: "f = prod_list fs" by auto
  fix fi assume fi: "fi  set fs"
  with primitive_prod_list[OF pr[unfolded f]] show "primitive fi" by auto
  from irreducible_primitive_connect[OF this] * pr[unfolded f] fi
  show "irreducible fi" by auto
  from * fi show "degree fi > 0" by (auto)
qed

lemma irreducible_imp_square_free:
  assumes irr: "irreducible (p::'a::idom poly)" shows "square_free p"
proof(intro square_freeI)
  from irr show p0: "p  0" by auto
  fix a assume "a * a dvd p"
  then obtain b where paab: "p = a * (a * b)" by (elim dvdE, auto)
  assume "degree a > 0"
  then have a1: "¬ a dvd 1" by (auto simp: poly_dvd_1)
  then have ab1: "¬ a * b dvd 1" using dvd_mult_left by auto
  from paab irr a1 ab1 show False by force
qed

(* TODO: Move *)
lemma not_mem_set_dropWhileD: "x  set (dropWhile P xs)  x  set xs  P x"
  by (metis dropWhile_append3 in_set_conv_decomp)

lemma primitive_reflect_poly:
  fixes f :: "'a :: comm_semiring_1 poly"
  shows "primitive (reflect_poly f) = primitive f"
proof-
  have "( a  set (coeffs f). x dvd a)  (a  set (dropWhile ((=) 0) (coeffs f)). x dvd a)" for x
    by (auto dest: not_mem_set_dropWhileD set_dropWhileD)
  then show ?thesis by (auto simp: primitive_def coeffs_reflect_poly)
qed

(* TODO: move *)
lemma gcd_list_sub:
  assumes "set xs  set ys" shows "gcd_list ys dvd gcd_list xs"
  by (metis Gcd_fin.subset assms semiring_gcd_class.gcd_dvd1)

lemma content_reflect_poly:
  "content (reflect_poly f) = content f" (is "?l = ?r")
proof-
  have l: "?l = gcd_list (dropWhile ((=) 0) (coeffs f))" (is "_ = gcd_list ?xs")
    by (simp add: content_def reflect_poly_def)
  have "set ?xs  set (coeffs f)" by (auto dest: set_dropWhileD)
  from gcd_list_sub[OF this]
  have "?r dvd gcd_list ?xs" by (simp add: content_def)
  with l have rl: "?r dvd ?l" by auto
  have "set (coeffs f)  set (0 # ?xs)" by (auto dest: not_mem_set_dropWhileD)
  from gcd_list_sub[OF this]
  have "gcd_list ?xs dvd ?r" by (simp add: content_def)
  with l have lr: "?l dvd ?r" by auto
  from rl lr show "?l = ?r" by (simp add: associated_eqI)
qed

lemma coeff_primitive_part: "content f * coeff (primitive_part f) i = coeff f i"
  using arg_cong[OF content_times_primitive_part[of f], of "λf. coeff f _", unfolded coeff_smult].

(* TODO: move *)
lemma smult_cancel[simp]:
  fixes c :: "'a :: idom"
  shows "smult c f = smult c g  c = 0  f = g"
proof-
  have l: "smult c f = [:c:] * f" by simp
  have r: "smult c g = [:c:] * g" by simp
  show ?thesis unfolding l r mult_cancel_left by simp
qed

lemma primitive_part_reflect_poly:
  fixes f :: "'a :: {semiring_gcd,idom} poly"
  shows "primitive_part (reflect_poly f) = reflect_poly (primitive_part f)" (is "?l = ?r")
  using content_times_primitive_part[of "reflect_poly f"]
proof-
  note content_reflect_poly[of f, symmetric]
  also have "smult (content (reflect_poly f)) ?l = reflect_poly f" by simp
  also have "... = reflect_poly (smult (content f) (primitive_part f))" by simp
  finally show ?thesis unfolding reflect_poly_smult smult_cancel by auto
qed

(* TODO: move *)
lemma reflect_poly_eq_zero[simp]:
  "reflect_poly f = 0  f = 0"
proof
  assume "reflect_poly f = 0"
  then have "coeff (reflect_poly f) 0 = 0" by simp
  then have "lead_coeff f = 0" by simp
  then show "f = 0" by simp
qed simp

lemma irreducibled_reflect_poly_main:
  fixes f :: "'a :: {idom, semiring_gcd} poly"
  assumes nz: "coeff f 0  0"
    and irr: "irreducibled (reflect_poly f)"
  shows "irreducibled f"
proof
  let ?r = reflect_poly
  from irr degree_reflect_poly_eq[OF nz] show "degree f > 0" by auto
  fix g h
  assume deg: "degree g < degree f" "degree h < degree f" and fgh: "f = g * h"
  from arg_cong[OF fgh, of "λ f. coeff f 0"] nz
  have nz': "coeff g 0  0" by (auto simp: coeff_mult_0)
  note rfgh = arg_cong[OF fgh, of reflect_poly, unfolded reflect_poly_mult[of g h]]
  from deg degree_reflect_poly_le[of g] degree_reflect_poly_le[of h] degree_reflect_poly_eq[OF nz]
  have "degree (?r h) < degree (?r f)" "degree (?r g) < degree (?r f)" by auto
  with irr rfgh show False by auto
qed

lemma irreducibled_reflect_poly:
  fixes f :: "'a :: {idom, semiring_gcd} poly"
  assumes nz: "coeff f 0  0"
  shows "irreducibled (reflect_poly f) = irreducibled f"
proof
  assume "irreducibled (reflect_poly f)" 
  from irreducibled_reflect_poly_main[OF nz this] show "irreducibled f" .
next
  from nz have nzr: "coeff (reflect_poly f) 0  0" by auto
  assume "irreducibled f" 
  with nz have "irreducibled (reflect_poly (reflect_poly f))" by simp
  from irreducibled_reflect_poly_main[OF nzr this]
  show "irreducibled (reflect_poly f)" .
qed

lemma irreducible_reflect_poly:
  fixes f :: "'a :: {idom,semiring_gcd} poly"
  assumes nz: "coeff f 0  0"
  shows "irreducible (reflect_poly f) = irreducible f" (is "?l = ?r")
proof (cases "degree f = 0")
  case True then obtain f0 where "f = [:f0:]" by (auto dest: degree0_coeffs)
  then show ?thesis by simp
next
  case deg: False
  show ?thesis
  proof (cases "primitive f")
    case False
    with deg irreducible_imp_primitive[of f] irreducible_imp_primitive[of "reflect_poly f"] nz
    show ?thesis unfolding primitive_reflect_poly by auto
  next
    case cf: True
    let ?r = "reflect_poly"
    from nz have nz': "coeff (?r f) 0  0" by auto
    let ?ir = irreducibled
    from irreducibled_reflect_poly[OF nz] irreducibled_reflect_poly[OF nz'] nz
    have "?ir f  ?ir (reflect_poly f)" by auto
    also have "...  irreducible (reflect_poly f)"
      by (rule irreducible_primitive_connect, unfold primitive_reflect_poly, fact cf)
    finally show ?thesis
      by (unfold irreducible_primitive_connect[OF cf], auto)
  qed
qed

(* TODO: Move *)
lemma reflect_poly_dvd: "(f :: 'a :: idom poly) dvd g  reflect_poly f dvd reflect_poly g"
  unfolding dvd_def by (auto simp: reflect_poly_mult)

lemma square_free_reflect_poly: fixes f :: "'a :: idom poly" 
  assumes sf: "square_free f" 
  and nz: "coeff f 0  0" 
shows "square_free (reflect_poly f)" unfolding square_free_def
proof (intro allI conjI impI notI)
  let ?r = reflect_poly 
  from sf[unfolded square_free_def] 
  have f0: "f  0" and sf: " q. 0 < degree q  q * q dvd f  False" by auto
  from f0 nz show "?r f = 0  False" by auto
  fix q
  assume 0: "0 < degree q" and dvd: "q * q dvd ?r f" 
  from dvd have "q dvd ?r f" by auto
  then obtain x where id: "?r f = q * x" by fastforce
  {
    assume "coeff q 0 = 0" 
    hence "coeff (?r f) 0 = 0" using id by (auto simp: coeff_mult)
    with nz have False by auto
  }
  hence nzq: "coeff q 0  0" by auto
  from dvd have "?r (q * q) dvd ?r (?r f)" by (rule reflect_poly_dvd)
  also have "?r (?r f) = f" using nz by auto
  also have "?r (q * q) = ?r q * ?r q" by (rule reflect_poly_mult)
  finally have "?r q * ?r q dvd f" .
  from sf[OF _ this] 0 nzq show False by simp
qed

lemma gcd_reflect_poly: fixes f :: "'a :: {factorial_ring_gcd, semiring_gcd_mult_normalize} poly"
  assumes nz: "coeff f 0  0" "coeff g 0  0"
  shows "gcd (reflect_poly f) (reflect_poly g) = normalize (reflect_poly (gcd f g))"
proof (rule sym, rule gcdI)
  have "gcd f g dvd f" by auto
  from reflect_poly_dvd[OF this]
  show "normalize (reflect_poly (gcd f g)) dvd reflect_poly f" by simp
  have "gcd f g dvd g" by auto
  from reflect_poly_dvd[OF this]
  show "normalize (reflect_poly (gcd f g)) dvd reflect_poly g" by simp
  show "normalize (normalize (reflect_poly (gcd f g))) = normalize (reflect_poly (gcd f g))" by auto
  fix h
  assume hf: "h dvd reflect_poly f" and hg: "h dvd reflect_poly g"
  from hf obtain k where "reflect_poly f = h * k" unfolding dvd_def by auto
  from arg_cong[OF this, of "λ f. coeff f 0", unfolded coeff_mult_0] nz(1) have h: "coeff h 0  0" by auto
  from reflect_poly_dvd[OF hf] reflect_poly_dvd[OF hg]
  have "reflect_poly h dvd f" "reflect_poly h dvd g" using nz by auto
  hence "reflect_poly h dvd gcd f g" by auto
  from reflect_poly_dvd[OF this] h have "h dvd reflect_poly (gcd f g)" by auto
  thus "h dvd normalize (reflect_poly (gcd f g))" by auto
qed

lemma linear_primitive_irreducible:
  fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  assumes deg: "degree f = 1" and cf: "primitive f"
  shows "irreducible f"
proof (intro irreducibleI)
  fix a b assume fab: "f = a * b"
  with deg have a0: "a  0" and b0: "b  0" by auto
  from deg[unfolded fab] degree_mult_eq[OF this] have "degree a = 0  degree b = 0" by auto
  then show "a dvd 1  b dvd 1"
  proof
    assume "degree a = 0"
    then obtain a0 where a: "a = [:a0:]" by (auto dest:degree0_coeffs)
    with fab have "c  set (coeffs f)  a0 dvd c" for c by (cases "a0 = 0", auto simp: coeffs_smult)
    with cf show ?thesis by (auto dest: primitiveD simp: a)
  next
    assume "degree b = 0"
    then obtain b0 where b: "b = [:b0:]" by (auto dest:degree0_coeffs)
    with fab have "c  set (coeffs f)  b0 dvd c" for c by (cases "b0 = 0", auto simp: coeffs_smult)
    with cf show ?thesis by (auto dest: primitiveD simp: b)
  qed
qed (insert deg, auto simp: poly_dvd_1)

lemma square_free_factorization_last_coeff_nz: 
  assumes sff: "square_free_factorization f (a, fs)" 
  and mem: "(fi,i)  set fs" 
  and nz: "coeff f 0  0" 
shows "coeff fi 0  0" 
proof 
  assume fi: "coeff fi 0 = 0" 
  note sff_list = square_free_factorization_prod_list[OF sff]
  note sff = square_free_factorizationD[OF sff]
  from sff_list have "coeff f 0 = a * coeff ((a, i)fs. a ^ Suc i) 0" by simp
  with split_list[OF mem] fi have "coeff f 0 = 0" 
    by (auto simp: coeff_mult)
  with nz show False by simp
qed



context
  fixes alg :: int_poly_factorization_algorithm
begin
(* main factorization algorithm for square-free, content-free, non-constant polynomial
   that do not have 0 as root, with special cases and reciprocal polynomials *)
definition main_int_poly_factorization :: "int poly  int poly list" where
  "main_int_poly_factorization f = (let df = degree f
    in if df = 1 then [f] else
    if abs (coeff f 0) < abs (coeff f df) ― ‹take reciprocal polynomial, if f(0) < lc(f)›
     then map reflect_poly (int_poly_factorization_algorithm alg (reflect_poly f))
     else int_poly_factorization_algorithm alg f)" 

(* preprocessing via square-free factorization *)
definition internal_int_poly_factorization :: "int poly  int × (int poly × nat) list" where
  "internal_int_poly_factorization f = (
    case square_free_factorization_int f of 
     (a,gis)  (a, [ (h,i) . (g,i)  gis, h  main_int_poly_factorization g ])
  )"

lemma internal_int_poly_factorization_code[code]: "internal_int_poly_factorization f = (
    case square_free_factorization_int f of (a,gis) 
   (a, concat (map (λ (g,i). (map (λ f. (f,i)) (main_int_poly_factorization g))) gis)))"
  unfolding internal_int_poly_factorization_def by auto

(* factorization for polynomials that do not have 0 as root,
   with special treatment of polynomials of degree at most 1 *)
definition factorize_int_last_nz_poly :: "int poly  int × (int poly × nat) list" where
  "factorize_int_last_nz_poly f = (let df = degree f
    in if df = 0 then (coeff f 0, []) else if df = 1 then (content f,[(primitive_part f,0)]) else
    internal_int_poly_factorization f)"

(* factorization for arbitrary polynomials *)
definition factorize_int_poly_generic :: "int poly  int × (int poly × nat) list" where
  "factorize_int_poly_generic f = (case x_split f of (n,g) ― ‹extract x^n›
     if g = 0 then (0,[]) else case factorize_int_last_nz_poly g of (a,fs)
     if n = 0 then (a,fs) else (a, (monom 1 1, n - 1) # fs))"


lemma factorize_int_poly_0[simp]: "factorize_int_poly_generic 0 = (0,[])"
  unfolding factorize_int_poly_generic_def x_split_def by simp

lemma main_int_poly_factorization: 
  assumes res: "main_int_poly_factorization f = fs" 
  and sf: "square_free f"
  and df: "degree f > 0"
  and nz: "coeff f 0  0" 
shows "f = prod_list fs  ( fi  set fs. irreducibled fi)" 
proof (cases "degree f = 1")
  case True
  with res[unfolded main_int_poly_factorization_def Let_def]
  have "fs = [f]" by auto
  with True show ?thesis by auto
next
  case False
  hence *: "(if degree f = 1 then t :: int poly list else e) = e" for t e by auto
  note res = res[unfolded main_int_poly_factorization_def Let_def *]
  show ?thesis
  proof (cases "abs (coeff f 0) < abs (coeff f (degree f))")
    case False
    with res have "int_poly_factorization_algorithm alg f = fs" by auto
    from int_poly_factorization_algorithm_irreducibled[OF this sf df] show ?thesis .
  next
    case True
    let ?f = "reflect_poly f" 
    from square_free_reflect_poly[OF sf nz] have sf: "square_free ?f" .
    from nz df have df: "degree ?f > 0" by simp
    from True res obtain gs where fs: "fs = map reflect_poly gs" 
      and gs: "int_poly_factorization_algorithm alg (reflect_poly f) = gs" 
      by auto    
    from int_poly_factorization_algorithm_irreducibled[OF gs sf df]
    have id: "reflect_poly ?f = reflect_poly (prod_list gs)" "?f = prod_list gs" 
      and irr: " gi. gi  set gs  irreducibled gi" by auto
    from id(1) have f_fs: "f = prod_list fs" unfolding fs using nz 
      by (simp add: reflect_poly_prod_list)
    {
      fix fi
      assume "fi  set fs" 
      from this[unfolded fs] obtain gi where gi: "gi  set gs" and fi: "fi = reflect_poly gi" by auto
      {
        assume "coeff gi 0 = 0" 
        with id(2) split_list[OF gi] have "coeff ?f 0 = 0" 
          by (auto simp: coeff_mult)
        with nz have False by auto
      }
      hence nzg: "coeff gi 0  0" by auto
      from irreducibled_reflect_poly[OF nzg] irr[OF gi] have "irreducibled fi" unfolding fi by simp
    }
    with f_fs show ?thesis by auto
  qed
qed

lemma internal_int_poly_factorization_mem:
  assumes f: "coeff f 0  0" 
  and res: "internal_int_poly_factorization f = (c,fs)"
  and mem: "(fi,i)  set fs"
  shows "irreducible fi" "irreducibled fi" and "primitive fi" and "degree fi  0"
proof -
  obtain a psi where a_psi: "square_free_factorization_int f = (a, psi)"
    by force
  from square_free_factorization_int[OF this]
  have sff: "square_free_factorization f (a, psi)"
    and cnt: " fi i. (fi, i)  set psi  primitive fi" by blast+
  from square_free_factorization_last_coeff_nz[OF sff _ f] 
  have nz_fi: " fi i. (fi, i)  set psi  coeff fi 0  0" by auto
  note res = res[unfolded internal_int_poly_factorization_def a_psi Let_def split]
  obtain fact where fact: "fact = (λ (q,i :: nat). (map (λ f. (f,i)) (main_int_poly_factorization q)))" by auto
  from res[unfolded split Let_def]
  have c: "c = a" and fs: "fs = concat (map fact psi)"
    unfolding fact by auto
  note sff' = square_free_factorizationD[OF sff]
  from mem[unfolded fs, simplified] obtain d j where psi: "(d,j)  set psi"
     and fi: "(fi, i)  set (fact (d,j))" by auto
  obtain hs where d: "main_int_poly_factorization d = hs" by force
  from fi[unfolded d split fact] have fi: "fi  set hs" by auto
  from main_int_poly_factorization[OF d _ _ nz_fi[OF psi]] sff'(2)[OF psi] cnt[OF psi]
  have main: "d = prod_list hs" " fi. fi  set hs  irreducibled fi" by auto
  from main split_list[OF fi] have "content fi dvd content d" by auto
  with cnt[OF psi] show cnt: "primitive fi" by simp
  from main(2)[OF fi] show irr: "irreducibled fi" .
  show "irreducible fi" 
    using irreducible_primitive_connect[OF cnt] irr by blast
  from irr show "degree fi  0" by auto
qed

lemma internal_int_poly_factorization:
  assumes f: "coeff f 0  0"
  and res: "internal_int_poly_factorization f = (c,fs)"
  shows "square_free_factorization f (c,fs)"
proof -
  obtain a psi where a_psi: "square_free_factorization_int f = (a, psi)"
    by force
  from square_free_factorization_int[OF this]
  have sff: "square_free_factorization f (a, psi)"
    and pr: " fi i. (fi, i)  set psi  primitive fi" by blast+
  obtain fact where fact: "fact = (λ (q,i :: nat). (map (λ f. (f,i)) (main_int_poly_factorization q)))" by auto
  from res[unfolded split Let_def]
  have c: "c = a" and fs: "fs = concat (map fact psi)"
    unfolding fact internal_int_poly_factorization_def a_psi by auto
  note sff' = square_free_factorizationD[OF sff]
  show ?thesis unfolding square_free_factorization_def split
  proof (intro conjI impI allI)
    show "f = 0  c = 0" "f = 0  fs = []" using sff'(4) unfolding c fs by auto
    {
      fix a i
      assume "(a,i)  set fs"
      from irreducible_imp_square_free internal_int_poly_factorization_mem[OF f res this]
      show "square_free a" "degree a > 0" by auto
    }
    from square_free_factorization_last_coeff_nz[OF sff _ f]
    have nz: " fi i. (fi, i)  set psi  coeff fi 0  0" by auto
    have eq: "f = smult c ((a, i)fs. a ^ Suc i)" unfolding
      prod.distinct_set_conv_list[OF sff'(5)]
      sff'(1) c
    proof (rule arg_cong[where f = "smult a"], unfold fs, insert sff'(2) nz, induct psi)
      case (Cons pi psi)
      obtain p i where pi: "pi = (p,i)" by force
      obtain gs where gs: "main_int_poly_factorization p = gs" by auto
      from Cons(2)[of p i] have p: "square_free p" "degree p > 0" unfolding pi by auto
      from Cons(3)[of p i] have nz: "coeff p 0  0" unfolding pi by auto
      from main_int_poly_factorization[OF gs p nz] have pgs: "p = prod_list gs" by auto
      have fact: "fact (p,i) = map (λ g. (g,i)) gs" unfolding fact split gs by auto
      have cong: " x y X Y. x = X  y = Y  x * y = X * Y" by auto
      show ?case unfolding pi list.simps prod_list.Cons split fact concat.simps prod_list.append
        map_append
      proof (rule cong)
        show "p ^ Suc i = ((a, i)map (λg. (g, i)) gs. a ^ Suc i)" unfolding pgs
          by (induct gs, auto simp: ac_simps power_mult_distrib)
        show "((a, i)psi. a ^ Suc i) = ((a, i)concat (map fact psi). a ^ Suc i)"
          by (rule Cons(1), insert Cons(2-3), auto)
      qed
    qed simp
    {
      fix i j l fi
      assume *: "j < length psi" "l < length (fact (psi ! j))" "fact (psi ! j) ! l = (fi, i)"
      from * have psi: "psi ! j  set psi" by auto
      obtain d k where dk: "psi ! j = (d,k)" by force
      with * have psij: "psi ! j = (d,i)" unfolding fact split by auto
      from sff'(2)[OF psi[unfolded psij]] have d: "square_free d" "degree d > 0" by auto
      from nz[OF psi[unfolded psij]] have d0: "coeff d 0  0" .
      from * psij fact
      have bz: "main_int_poly_factorization d = map fst (fact (psi ! j))" by (auto simp: o_def)
      from main_int_poly_factorization[OF bz d d0] pr[OF psi[unfolded dk]]
      have dhs: "d = prod_list (map fst (fact (psi ! j)))" by auto
      from * have mem: "fi  set (map fst (fact (psi ! j)))"
        by (metis fst_conv image_eqI nth_mem set_map)
      from mem dhs psij d have " d. fi  set (map fst (fact (psi ! j))) 
        d = prod_list (map fst (fact (psi ! j))) 
        psi ! j = (d, i) 
        square_free d" by blast
    } note deconstruct = this
    {
      fix k K fi i Fi I
      assume k: "k < length fs" "K < length fs" and f: "fs ! k = (fi, i)" "fs ! K = (Fi, I)"
      and diff: "k  K"
      from nth_concat_diff[OF k[unfolded fs] diff, folded fs, unfolded length_map]
        obtain j l J L where diff: "(j, l)  (J, L)"
          and j: "j < length psi" "J < length psi"
          and l: "l < length (map fact psi ! j)" "L < length (map fact psi ! J)"
          and fs: "fs ! k = map fact psi ! j ! l" "fs ! K = map fact psi ! J ! L" by blast+
      hence psij: "psi ! j  set psi" by auto
      from j have id: "map fact psi ! j = fact (psi ! j)" "map fact psi ! J = fact (psi ! J)" by auto
      note l = l[unfolded id] note fs = fs[unfolded id]
      from j have psi: "psi ! j  set psi" "psi ! J  set psi" by auto
      from deconstruct[OF j(1) l(1) fs(1)[unfolded f, symmetric]]
      obtain d where mem: "fi  set (map fst (fact (psi ! j)))"
        and d: "d = prod_list (map fst (fact (psi ! j)))" "psi ! j = (d, i)" "square_free d" by blast
      from deconstruct[OF j(2) l(2) fs(2)[unfolded f, symmetric]]
      obtain D where Mem: "Fi  set (map fst (fact (psi ! J)))"
        and D: "D = prod_list (map fst (fact (psi ! J)))" "psi ! J = (D, I)" "square_free D" by blast
      from pr[OF psij[unfolded d(2)]] have cnt: "primitive d" .
      have "coprime fi Fi"
      proof (cases "J = j")
        case False
        from sff'(5) False j have "(d,i)  (D,I)"
          unfolding distinct_conv_nth d(2)[symmetric] D(2)[symmetric] by auto
        from sff'(3)[OF psi[unfolded d(2) D(2)] this]
        have cop: "coprime d D" by auto
        from prod_list_dvd[OF mem, folded d(1)] have fid: "fi dvd d" by auto
        from prod_list_dvd[OF Mem, folded D(1)] have FiD: "Fi dvd D" by auto
        from coprime_divisors[OF fid FiD] cop show ?thesis by simp
      next
        case True note id = this
        from id diff have diff: "l  L" by auto
        obtain bz where bz: "bz = map fst (fact (psi ! j))" by auto
        from fs[unfolded f] l
        have fi: "fi = bz ! l" "Fi = bz ! L"
          unfolding id bz by (metis fst_conv nth_map)+
        from d[folded bz] have sf: "square_free (prod_list bz)" by auto
        from d[folded bz] cnt have cnt: "content (prod_list bz) = 1" by auto
        from l have l: "l < length bz" "L < length bz" unfolding bz id by auto
        from l fi have "fi  set bz" by auto
        from content_dvd_1[OF cnt prod_list_dvd[OF this]] have cnt: "content fi = 1" .
        obtain g where g: "g = gcd fi Fi" by auto
        have g': "g dvd fi" "g dvd Fi" unfolding g by auto
        define bef where "bef = take l bz"
        define aft where "aft = drop (Suc l) bz"
        from id_take_nth_drop[OF l(1)] l have bz: "bz = bef @ fi # aft" and bef: "length bef = l"
          unfolding bef_def aft_def fi by auto
        with l diff have mem: "Fi  set (bef @ aft)" unfolding fi(2) by (auto simp: nth_append)
        from split_list[OF this] obtain Bef Aft where ba: "bef @ aft = Bef @ Fi # Aft" by auto
        have "prod_list bz = fi * prod_list (bef @ aft)" unfolding bz by simp
        also have "prod_list (bef @ aft) = Fi * prod_list (Bef @ Aft)" unfolding ba by auto
        finally have "fi * Fi dvd prod_list bz" by auto
        with g' have "g * g dvd prod_list bz" by (meson dvd_trans mult_dvd_mono)
        with sf[unfolded square_free_def] have deg: "degree g = 0" by auto
        from content_dvd_1[OF cnt g'(1)] have cnt: "content g = 1" .
        from degree0_coeffs[OF deg] obtain c where gc: "g = [: c :]" by auto
        from cnt[unfolded gc content_def, simplified] have "abs c = 1"
          by (cases "c = 0", auto)
        with g gc have "gcd fi Fi  {1,-1}" by fastforce
        thus "coprime fi Fi"
          by (auto intro!: gcd_eq_1_imp_coprime)
            (metis dvd_minus_iff dvd_refl is_unit_gcd_iff one_neq_neg_one)
      qed
    } note cop = this
    show dist: "distinct fs" unfolding distinct_conv_nth
    proof (intro impI allI)
      fix k K
      assume k: "k < length fs" "K < length fs" and diff: "k  K"
      obtain fi i Fi I where f: "fs ! k = (fi,i)" "fs ! K = (Fi,I)" by force+
      from cop[OF k f diff] have cop: "coprime fi Fi" .
      from k(1) f(1) have "(fi,i)  set fs" unfolding set_conv_nth by force
      from internal_int_poly_factorization_mem[OF assms(1) res this] have "degree fi > 0" by auto
      hence "¬ is_unit fi" by (simp add: poly_dvd_1)
      with cop coprime_id_is_unit[of fi] have "fi  Fi" by auto
      thus "fs ! k  fs ! K" unfolding f by auto
    qed
    show "f = smult c ((a, i)set fs. a ^ Suc i)" unfolding eq
      prod.distinct_set_conv_list[OF dist] by simp
    fix fi i Fi I
    assume mem: "(fi, i)  set fs" "(Fi,I)  set fs" and diff: "(fi, i)  (Fi, I)"
    then obtain k K where k: "k < length fs" "K < length fs"
      and f: "fs ! k = (fi, i)" "fs ! K = (Fi, I)" unfolding set_conv_nth by auto
    with diff have diff: "k  K" by auto
    from cop[OF k f diff] show "Rings.coprime fi Fi" by auto
  qed
qed

lemma factorize_int_last_nz_poly: assumes res: "factorize_int_last_nz_poly f = (c,fs)"
    and nz: "coeff f 0  0"
shows "square_free_factorization f (c,fs)"
  "(fi,i)  set fs  irreducible fi"
  "(fi,i)  set fs  degree fi  0"
proof (atomize(full))
  from nz have lz: "lead_coeff f  0" by auto
  note res = res[unfolded factorize_int_last_nz_poly_def Let_def]
  consider (0) "degree f = 0"
    | (1) "degree f = 1"
    | (2) "degree f > 1" by linarith
  then show "square_free_factorization f (c,fs)  ((fi,i)  set fs  irreducible fi)  ((fi,i)  set fs  degree fi  0)"
  proof cases
    case 0
    from degree0_coeffs[OF 0] obtain a where f: "f = [:a:]" by auto
    from res show ?thesis unfolding square_free_factorization_def f by auto
  next
    case 1
    then have irr: "irreducible (primitive_part f)"
      by (auto intro!: linear_primitive_irreducible content_primitive_part)
    from irreducible_imp_square_free[OF irr] have sf: "square_free (primitive_part f)" .
    from 1 have f0: "f  0" by auto
    from res irr sf f0 show ?thesis unfolding square_free_factorization_def by (auto simp: 1)
  next
    case 2
    with res have "internal_int_poly_factorization f = (c,fs)" by auto
    from internal_int_poly_factorization[OF nz this] internal_int_poly_factorization_mem[OF nz this]
    show ?thesis by auto
  qed
qed

lemma factorize_int_poly: assumes res: "factorize_int_poly_generic f = (c,fs)"
shows "square_free_factorization f (c,fs)"
  "(fi,i)  set fs  irreducible fi"
  "(fi,i)  set fs  degree fi  0"
proof (atomize(full))
  obtain n g where xs: "x_split f = (n,g)" by force
  obtain d hs where fact: "factorize_int_last_nz_poly g = (d,hs)" by force
  from res[unfolded factorize_int_poly_generic_def xs split fact]
  have res: "(if g = 0 then (0, []) else if n = 0 then (d, hs) else (d, (monom 1 1, n - 1) # hs)) = (c, fs)" .
  note xs = x_split[OF xs]
  show "square_free_factorization f (c,fs)  ((fi,i)  set fs  irreducible fi)  ((fi,i)  set fs  degree fi  0)"
  proof (cases "g = 0")
    case True
    hence "f = 0" "c = 0" "fs = []" using res xs by auto
    thus ?thesis unfolding square_free_factorization_def by auto
  next
    case False
    with xs have "¬ monom 1 1 dvd g" by auto
    hence "coeff g 0  0" by (simp add: monom_1_dvd_iff')
    note fact = factorize_int_last_nz_poly[OF fact this]
    let ?x = "monom 1 1 :: int poly"
    have x: "content ?x = 1  lead_coeff ?x = 1  degree ?x = 1"
      by (auto simp add: degree_monom_eq monom_Suc content_def)
    from res False have res: "(if n = 0 then (d, hs) else (d, (?x, n - 1) # hs)) = (c, fs)" by auto
    show ?thesis
    proof (cases n)
      case 0
      with res xs have id: "fs = hs" "c = d" "f = g" by auto
      from fact show ?thesis unfolding id by auto
    next
      case (Suc m)
      with res have id: "c = d" "fs = (?x,m) # hs" by auto
      from Suc xs have fg: "f = monom 1 (Suc m) * g" and dvd: "¬ ?x dvd g" by auto
      from x linear_primitive_irreducible[of ?x] have irr: "irreducible ?x" by auto
      from irreducible_imp_square_free[OF this] have sfx: "square_free ?x" .
      from irr fact have one: "(fi, i)  set fs  irreducible fi  degree fi  0" unfolding id by (auto simp: degree_monom_eq)
      have fg: "f = ?x ^ n * g" unfolding fg Suc by (metis x_pow_n)
      from x have degx: "degree ?x = 1" by simp
      note sf = square_free_factorizationD[OF fact(1)]
      {
        fix a i
        assume ai: "(a,i)  set hs"
        with sf(4) have g0: "g  0" by auto
        from split_list[OF ai] obtain ys zs where hs: "hs = ys @ (a,i) # zs" by auto
        have "a dvd g" unfolding square_free_factorization_prod_list[OF fact(1)] hs
          by (rule dvd_smult, simp add: ac_simps)
        moreover have "¬ ?x dvd g" using xs[unfolded Suc] by auto
        ultimately have dvd: "¬ ?x dvd a" using dvd_trans by blast
        from sf(2)[OF ai] have "a  0" by auto
        have "1 = gcd ?x a"
        proof (rule gcdI)
          fix d
          assume d: "d dvd ?x" "d dvd a"
          from content_dvd_contentI[OF d(1)] x have cnt: "is_unit (content d)" by auto
          show "is_unit d"
          proof (cases "degree d = 1")
            case False
            with divides_degree[OF d(1), unfolded degx] have "degree d = 0" by auto
            from degree0_coeffs[OF this] obtain c where dc: "d = [:c:]" by auto
            from cnt[unfolded dc] have "is_unit c" by (auto simp: content_def, cases "c = 0", auto)
            hence "d * d = 1" unfolding dc by (auto, cases "c = -1"; cases "c = 1", auto)
            thus "is_unit d" by (metis dvd_triv_right)
          next
            case True
            from d(1) obtain e where xde: "?x = d * e" unfolding dvd_def by auto
            from arg_cong[OF this, of degree] degx have "degree d + degree e = 1"
              by (metis True add.right_neutral degree_0 degree_mult_eq one_neq_zero)
            with True have "degree e = 0" by auto
            from degree0_coeffs[OF this] xde obtain e where xde: "?x = [:e:] * d" by auto
            from arg_cong[OF this, of content, unfolded content_mult] x
            have "content [:e:] * content d = 1" by auto
            also have "content [:e :] = abs e" by (auto simp: content_def, cases "e = 0", auto)
            finally have "¦e¦ * content d = 1" .
            from pos_zmult_eq_1_iff_lemma[OF this] have "e * e = 1" by (cases "e = 1"; cases "e = -1", auto)
            with arg_cong[OF xde, of "smult e"] have "d = ?x * [:e:]" by auto
            hence "?x dvd d" unfolding dvd_def by blast
            with d(2) have "?x dvd a" by (metis dvd_trans)
            with dvd show ?thesis by auto
          qed
        qed auto
        hence "coprime ?x a"
          by (simp add: gcd_eq_1_imp_coprime)
        note this dvd
      } note hs_dvd_x = this
      from hs_dvd_x[of ?x m]
      have nmem: "(?x,m)  set hs" by auto
      hence eq: "?x ^ n * g = smult d ((a, i)set fs. a ^ Suc i)"
        unfolding sf(1) unfolding id Suc by simp
      have eq0: "?x ^ n * g = 0  g = 0" by simp
      have "square_free_factorization f (d,fs)" unfolding fg id(1) square_free_factorization_def split eq0 unfolding eq
      proof (intro conjI allI impI, rule refl)
        fix a i
        assume ai: "(a,i)  set fs"
        thus "square_free a" "degree a > 0" using sf(2) sfx degx unfolding id by auto
        fix b j
        assume bj: "(b,j)  set fs" and diff: "(a,i)  (b,j)"
        consider (hs_hs) "(a,i)  set hs" "(b,j)  set hs"
          | (hs_x) "(a,i)  set hs" "b = ?x"
          | (x_hs) "(b,j)  set hs" "a = ?x"
          using ai bj diff unfolding id by auto
        thus "Rings.coprime a b"
        proof cases
          case hs_hs
          from sf(3)[OF this diff] show ?thesis .
        next
          case hs_x
          from hs_dvd_x(1)[OF hs_x(1)] show ?thesis unfolding hs_x(2)
            by (simp add: ac_simps)
        next
          case x_hs
          from hs_dvd_x(1)[OF x_hs(1)] show ?thesis unfolding x_hs(2)
            by simp
        qed
      next
        show "g = 0  d = 0" using sf(4) by auto
        show "g = 0  fs = []" using sf(4) xs Suc by auto
        show "distinct fs" using sf(5) nmem unfolding id by auto
      qed
      thus ?thesis using one unfolding id by auto
    qed
  qed
qed
end

lift_definition berlekamp_zassenhaus_factorization_algorithm :: int_poly_factorization_algorithm
  is berlekamp_zassenhaus_factorization 
  using berlekamp_zassenhaus_factorization_irreducibled by blast

abbreviation factorize_int_poly where 
  "factorize_int_poly  factorize_int_poly_generic berlekamp_zassenhaus_factorization_algorithm" 
end

Theory Factorize_Rat_Poly

(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection ‹Factoring Rational Polynomials›

text ‹We combine the factorization algorithm for integer polynomials
  with Gauss Lemma to a factorization algorithm for rational polynomials.›
theory Factorize_Rat_Poly
imports 
  Factorize_Int_Poly
begin

(*TODO: Move*)
interpretation content_hom: monoid_mult_hom
  "content::'a::{factorial_semiring, semiring_gcd, normalization_semidom_multiplicative} poly  _"
by (unfold_locales, auto simp: content_mult)

lemma prod_dvd_1_imp_all_dvd_1:
  assumes "finite X" and "prod f X dvd 1" and "x  X" shows "f x dvd 1"
proof (insert assms, induct rule:finite_induct)
  case IH: (insert x' X)
  show ?case
  proof (cases "x = x'")
    case True
    with IH show ?thesis using  dvd_trans[of "f x'" "f x' * _" 1]
      by (metis dvd_triv_left prod.insert)
  next
    case False
    then show ?thesis using IH by (auto intro!: IH(3) dvd_trans[of "prod f X" "_ * prod f X" 1])
  qed
qed simp

context
  fixes alg :: int_poly_factorization_algorithm
begin
definition factorize_rat_poly_generic :: "rat poly  rat × (rat poly × nat) list" where
  "factorize_rat_poly_generic f = (case rat_to_normalized_int_poly f of
     (c,g)  case factorize_int_poly_generic alg g of (d,fs)  (c * rat_of_int d, 
     map (λ (fi,i). (map_poly rat_of_int fi, i)) fs))" 
  
lemma factorize_rat_poly_0[simp]: "factorize_rat_poly_generic 0 = (0,[])" 
  unfolding factorize_rat_poly_generic_def rat_to_normalized_int_poly_def by simp

lemma factorize_rat_poly:
  assumes res: "factorize_rat_poly_generic f = (c,fs)"
  shows "square_free_factorization f (c,fs)"
    and "(fi,i)  set fs  irreducible fi"
proof(atomize(full), cases "f=0", goal_cases)
  case 1 with res show ?case by (auto simp: square_free_factorization_def)
next
  case 2 show ?case
  proof (unfold square_free_factorization_def split, intro conjI impI allI)
    let ?r = rat_of_int
    let ?rp = "map_poly ?r" 
    obtain d g where ri: "rat_to_normalized_int_poly f = (d,g)" by force
    obtain e gs where fi: "factorize_int_poly_generic alg g = (e,gs)" by force
    from res[unfolded factorize_rat_poly_generic_def ri fi split]
    have c: "c = d * ?r e" and fs: "fs = map (λ (fi,i). (?rp fi, i)) gs" by auto
    from factorize_int_poly[OF fi]
    have irr: "(fi, i)  set gs  irreducible fi  content fi = 1" for fi i
      using irreducible_imp_primitive[of fi] by auto
    note sff = factorize_int_poly(1)[OF fi]
    note sff' = square_free_factorizationD[OF sff]
    {
      fix n f 
      have "?rp (f ^ n) = (?rp f) ^ n"
        by (induct n, auto simp: hom_distribs)
    } note exp = this
    show dist: "distinct fs" using sff'(5) unfolding fs distinct_map inj_on_def by auto
    interpret mh: map_poly_inj_idom_hom rat_of_int..
    have "f = smult d (?rp g)" using rat_to_normalized_int_poly[OF ri] by auto
    also have " = smult d (?rp (smult e ((a, i)set gs. a ^ Suc i)))" using sff'(1) by simp
    also have " = smult c (?rp ((a, i)set gs. a ^ Suc i))" unfolding c by (simp add: hom_distribs)
    also have "?rp ((a, i)set gs. a ^ Suc i) = ((a, i)set fs. a ^ Suc i)"
      unfolding prod.distinct_set_conv_list[OF sff'(5)] prod.distinct_set_conv_list[OF dist]
      unfolding fs
      by (insert exp, auto intro!: arg_cong[of _ _ "λx. prod_list (map x gs)"] simp: hom_distribs of_int_poly_hom.hom_prod_list)
    finally show f: "f = smult c ((a, i)set fs. a ^ Suc i)" by auto
    {
      fix a i
      assume ai: "(a,i)  set fs" 
      from ai obtain A where a: "a = ?rp A" and A: "(A,i)  set gs" unfolding fs by auto
      fix b j
      assume "(b,j)  set fs" and diff: "(a,i)  (b,j)"
      from this(1) obtain B where b: "b = ?rp B" and B: "(B,j)  set gs" unfolding fs by auto
      from diff[unfolded a b] have "(A,i)  (B,j)" by auto
      from sff'(3)[OF A B this]
      show "Rings.coprime a b"
        by (auto simp add: coprime_iff_gcd_eq_1 gcd_rat_to_gcd_int a b)
    }
    {
      fix fi i
      assume "(fi,i)  set fs" 
      then obtain gi where fi: "fi = ?rp gi" and gi: "(gi,i)  set gs" unfolding fs by auto
      from irr[OF gi] have cf_gi: "primitive gi" by auto
      then have "primitive (?rp gi)" by (auto simp: content_field_poly)
      note [simp] = irreducible_primitive_connect[OF cf_gi] irreducible_primitive_connect[OF this]
      show "irreducible fi"
      using irr[OF gi] fi irreducibled_int_rat[of gi,simplified] by auto
      then show "degree fi > 0" "square_free fi" unfolding fi
        by (auto intro: irreducible_imp_square_free)
    }
    {
      assume "f = 0" with ri have *: "d = 1" "g = 0" unfolding rat_to_normalized_int_poly_def by auto
      with sff'(4)[OF *(2)] show "c = 0" "fs = []" unfolding c fs by auto
    }
  qed
qed

end

abbreviation factorize_rat_poly where 
  "factorize_rat_poly  factorize_rat_poly_generic berlekamp_zassenhaus_factorization_algorithm" 

end